diff --git a/c/gc.c b/c/gc.c index cc3e802fdb..1c06d1038e 100644 --- a/c/gc.c +++ b/c/gc.c @@ -238,7 +238,7 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { XCP = *(pcp);\ if ((SI = SegInfo(ptr_get_segment(XCP)))->space & space_old) { \ iptr CO;\ - CO = ENTRYOFFSET(XCP) + ((uptr)XCP - (uptr)&ENTRYOFFSET(XCP));\ + CO = ENTRYOFFSET(XCP) + ((uptr)XCP - (uptr)ENTRYOFFSETADDR(XCP));\ relocate_code(pcp,XCP,CO,SI)\ }\ } @@ -1975,7 +1975,7 @@ static void sweep_stack(base, fp, ret) uptr base, fp, ret; { } else { iptr index; - relocate(&ENTRYLIVEMASK(oldret)) + relocate(ENTRYNONCOMPACTLIVEMASKADDR(oldret)) num = ENTRYLIVEMASK(oldret); index = BIGLEN(num); while (index-- != 0) { diff --git a/c/types.h b/c/types.h index 0fb3810dea..30c45ffdac 100644 --- a/c/types.h +++ b/c/types.h @@ -272,9 +272,22 @@ typedef struct _bucket_pointer_list { #define FWDMARKER(p) FORWARDMARKER((uptr)UNTYPE_ANY(p)) #define FWDADDRESS(p) FORWARDADDRESS((uptr)UNTYPE_ANY(p)) -#define ENTRYFRAMESIZE(x) RPHEADERFRAMESIZE((uptr)(x) - size_rp_header) -#define ENTRYOFFSET(x) RPHEADERTOPLINK((uptr)(x) - size_rp_header) -#define ENTRYLIVEMASK(x) RPHEADERLIVEMASK((uptr)(x) - size_rp_header) +#define ISENTRYCOMPACT(x) (RPCOMPACTHEADERMASKANDSIZE((uptr)(x) - size_rp_compact_header) & compact_header_mask) +#define COMPACTENTRYFIELD(x, offset) (RPCOMPACTHEADERMASKANDSIZE((uptr)(x) - size_rp_compact_header) >> offset) + +#define ENTRYFRAMESIZE(x) (ISENTRYCOMPACT(x) \ + ? ((COMPACTENTRYFIELD(x, compact_frame_words_offset) & compact_frame_words_mask) << log2_ptr_bytes) \ + : RPHEADERFRAMESIZE((uptr)(x) - size_rp_header)) +#define ENTRYOFFSET(x) (ISENTRYCOMPACT(x) \ + ? RPCOMPACTHEADERTOPLINK((uptr)(x) - size_rp_compact_header) \ + : RPHEADERTOPLINK((uptr)(x) - size_rp_header)) +#define ENTRYOFFSETADDR(x) (ISENTRYCOMPACT(x) \ + ? &RPCOMPACTHEADERTOPLINK((uptr)(x) - size_rp_compact_header) \ + : &RPHEADERTOPLINK((uptr)(x) - size_rp_header)) +#define ENTRYLIVEMASK(x) (ISENTRYCOMPACT(x) \ + ? FIX(COMPACTENTRYFIELD(x, compact_frame_mask_offset)) \ + : RPHEADERLIVEMASK((uptr)(x) - size_rp_header)) +#define ENTRYNONCOMPACTLIVEMASKADDR(x) (&RPHEADERLIVEMASK((uptr)(x) - size_rp_header)) #define PORTFD(x) ((iptr)PORTHANDLER(x)) #define PORTGZFILE(x) ((gzFile)(PORTHANDLER(x))) diff --git a/configure b/configure index dba04e03f8..b8e88737d2 100755 --- a/configure +++ b/configure @@ -25,7 +25,8 @@ machs=$machs$sep2$last m="" w="" -threads=no +threads=yes +nothreads=no temproot="" help=no gzipmanpages=yes @@ -171,6 +172,9 @@ while [ $# != 0 ] ; do --threads) threads=yes ;; + --nothreads) + threads=no + ;; --64) bits=64 ;; @@ -307,7 +311,7 @@ if [ "$bits" = "" ] ; then fi if [ "$threads" = "" ] ; then - threads=no + threads=yes fi if [ "$m" = "" ] ; then @@ -351,6 +355,7 @@ if [ "$help" = "yes" ]; then echo " --machine= explicitly specify machine type ($m)" echo " -m= same as --machine ($m)" echo " --threads specify threaded version ($threads)" + echo " --nothreads specify non-threaded version ($nothreads)" echo " --32|--64 specify 32/64-bit version ($bits)" echo " --disable-x11 disable X11 support" echo " --disable-curses disable [n]curses support" diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index 13d002db2c..3e876287c7 100644 --- a/makefiles/Mf-install.in +++ b/makefiles/Mf-install.in @@ -62,7 +62,7 @@ InstallLZ4Target= # no changes should be needed below this point # ############################################################################### -Version=csv9.5.3.14 +Version=csv9.5.3.15 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/s/arm32.ss b/s/arm32.ss index dd87ba3d59..d4600323e1 100644 --- a/s/arm32.ss +++ b/s/arm32.ss @@ -893,7 +893,8 @@ asm-pop-multiple asm-shiftop asm-logand asm-lognot asm-logtest asm-fl-relop asm-relop asm-push-multiple asm-vpush-multiple asm-indirect-jump asm-literal-jump - asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header + asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label + asm-rp-header asm-rp-compact-header asm-indirect-call asm-condition-code asm-fl-load/store asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc @@ -2283,21 +2284,41 @@ (let ([mrv-error `(abs ,(constant code-data-disp) (library-code ,(lookup-libspec values-error)))]) (lambda (code* mrvl fs lpm func code-size) - (cons* - (if (target-fixnum? lpm) - `(long . ,(fix lpm)) - `(abs 0 (object ,lpm))) - (aop-cons* `(asm livemask: ,(format "~b" lpm)) - '(code-top-link) - (aop-cons* `(asm code-top-link) - `(long . ,fs) - (aop-cons* `(asm "frame size:" ,fs) - (if mrvl - (asm-data-label code* mrvl 0 func code-size) - (cons* - mrv-error - (aop-cons* `(asm "mrv point:" ,mrv-error) - code*)))))))))) + (let* ([code* (cons* `(long . ,fs) + (aop-cons* `(asm "frame size:" ,fs) + code*))] + [code* (cons* (if (target-fixnum? lpm) + `(long . ,(fix lpm)) + `(abs 0 (object ,lpm))) + (aop-cons* `(asm livemask: ,(format "~b" lpm)) + code*))] + [code* (if mrvl + (asm-data-label code* mrvl 0 func code-size) + (cons* + mrv-error + (aop-cons* `(asm "mrv point:" ,mrv-error) + code*)))] + [code* (cons* + '(code-top-link) + (aop-cons* `(asm code-top-link) + code*))]) + code*)))) + + (define asm-rp-compact-header + (lambda (code* err? fs lpm func code-size) + (let* ([code* (cons* `(long . ,(fxior (constant compact-header-mask) + (if err? + (constant compact-header-values-error-mask) + 0) + (fxsll fs (constant compact-frame-words-offset)) + (fxsll lpm (constant compact-frame-mask-offset)))) + (aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue))) + code*))] + [code* (cons* + '(code-top-link) + (aop-cons* `(asm code-top-link) + code*))]) + code*))) ; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly (define asm-return (lambda () (emit bx (cons 'reg %lr) '()))) diff --git a/s/cmacros.ss b/s/cmacros.ss index 812f5dc57d..ac21c185de 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -328,7 +328,7 @@ [(_ foo e1 e2) e1] ... [(_ bar e1 e2) e2]))))]))) -(define-constant scheme-version #x0905030E) +(define-constant scheme-version #x0905030F) (define-syntax define-machine-types (lambda (x) @@ -1522,10 +1522,10 @@ [ptr link])) (define-primitive-structure-disps rp-header typemod - ([ptr livemask] - [uptr toplink] - [iptr frame-size] - [uptr mv-return-address])) + ([uptr toplink] + [uptr mv-return-address] + [ptr livemask] + [iptr frame-size])) ; low bit is 0 to distinguish from a `rp-compact-header` (define-constant return-address-mv-return-address-disp (- (constant rp-header-mv-return-address-disp) (constant size-rp-header))) (define-constant return-address-frame-size-disp @@ -1535,6 +1535,32 @@ (define-constant return-address-livemask-disp (- (constant rp-header-livemask-disp) (constant size-rp-header))) +(define-primitive-structure-disps rp-compact-header typemod + ([uptr toplink] + [iptr mask+size+mode])) ; low bit is 1 to distinguish from a `rp-header` +;; mask+size+mode: bit 0 is 1 [=> compact-header-mask] +;; +;; bit 1 is 0 for mv-return-address = return-address +;; bit 1 is 1 for mv-return-address = values-error +;; +;; bits 2 through 1+compact-frame-size-bits = frame size in words +;; +;; remaining bits are livemask +(define-constant compact-header-mask #b01) +(define-constant compact-header-values-error-mask #b10) +(define-constant compact-frame-words-offset 2) +(define-constant compact-frame-words-bits + (constant-case ptr-bits + [(32) 4] + [(64) 5])) +(define-constant compact-frame-max-words (fx- (expt 2 (constant compact-frame-words-bits)) 1)) +(define-constant compact-frame-words-mask (constant compact-frame-max-words)) +(define-constant compact-frame-mask-offset (fx+ 2 (constant compact-frame-words-bits))) +(define-constant compact-return-address-toplink-disp + (- (constant rp-compact-header-toplink-disp) (constant size-rp-compact-header))) +(define-constant compact-return-address-mask+size+mode-disp + (- (constant rp-compact-header-mask+size+mode-disp) (constant size-rp-compact-header))) + (define-syntax bigit-type (lambda (x) (with-syntax ([type (datum->syntax #'* (filter-scheme-type 'bigit))]) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index b1671ac4c8..4643092914 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -1187,6 +1187,26 @@ ,(make-info-alloc (constant tag) save-flrv? save-asm-ra?) (immediate ,(c-alloc-align size))))]))) + (define-syntax %mv-jump + (lambda (x) + (syntax-case x () + [(k ret-reg (live ...)) + (with-implicit (k quasiquote %mref %inline %constant) + #'`(if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ;; compact: use regular return or error? + (if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-values-error-mask)) + ;; values error: + (jump (literal ,(make-info-literal #f 'library-code + (lookup-libspec values-error) + (constant code-data-disp))) + (live ...)) + ;; regular return point: + (jump ret-reg (live ...))) + ;; non-compact rp-header + (jump ,(%mref ret-reg ,(constant return-address-mv-return-address-disp)) (live ...))))]))) + (define-pass np-recognize-let : L1 (ir) -> L2 () (definitions (define seqs-and-profiles? @@ -9432,23 +9452,30 @@ (constant log2-ptr-bytes))]) (define-inline 3 $continuation-return-code [(e) - (bind #t ([t (%inline + - ,(%mref ,e ,(constant continuation-return-address-disp)) - ,(%constant return-address-toplink-disp))]) - (%inline - ,t ,(%mref ,t 0)))]) + (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))]) + (bind #t ([t `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ,(%inline + ,ra ,(%constant compact-return-address-toplink-disp)) + ,(%inline + ,ra ,(%constant return-address-toplink-disp)))]) + (%inline - ,t ,(%mref ,t 0))))]) (define-inline 3 $continuation-return-offset [(e) - (build-fix - (%inline - - ,(%mref - ,(%mref ,e ,(constant continuation-return-address-disp)) - ,(constant return-address-toplink-disp)) - ,(%constant return-address-toplink-disp)))]) + (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))]) + (build-fix + `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ,(%inline - ,(%mref ,ra ,(constant compact-return-address-toplink-disp)) + ,(%constant compact-return-address-toplink-disp)) + ,(%inline - ,(%mref ,ra ,(constant return-address-toplink-disp)) + ,(%constant return-address-toplink-disp)))))]) (define-inline 3 $continuation-return-livemask [(e) - (%mref - ,(%mref ,e ,(constant continuation-return-address-disp)) - ,(constant return-address-livemask-disp))]) + (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))]) + (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) + `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) + ,(%inline sll ,(%inline srl ,mask+size+mode ,(%constant compact-frame-mask-offset)), + (%constant fixnum-offset)) + ,(%mref ,ra ,(constant return-address-livemask-disp)))))]) (define-inline 3 $continuation-stack-ref [(e-k e-i) (%mref @@ -10842,7 +10869,7 @@ (Effect : Effect (ir) -> Effect () [(mvset ,info (,mdcl ,[t0?] ,[t1] ...) (,[t*] ...) ((,x** ...) ,interface* ,l*) ...) `(mvset ,info (,mdcl ,t0? ,t1 ...) (,t* ...) ((,x** ...) ...) - ,(flatten-mvclauses x** interface* l*))])) + ,(flatten-mvclauses x** interface* l*))])) (define-pass np-impose-calling-conventions : L12 (ir) -> L13 () (definitions @@ -10934,6 +10961,7 @@ (define set-return-address (lambda (tl) (if rpl + ;; `label-ref` offset is adjusted later if return point turns out to be compact (%seq (set! ,%ref-ret (label-ref ,rpl ,(constant size-rp-header))) ,tl) (meta-cond [(real-register? '%ret) (%seq (set! ,%ret ,(get-fv 0)) ,tl)] @@ -11081,17 +11109,17 @@ [(literal ,info) #f] [else #t]))) (define build-nontail-call - (lambda (info mdcl t0 t1* tc* nfv** mrvl prepare-for-consumer? build-postlude) + (lambda (info mdcl t0 t1* tc* nfv** mrvl mrvl-is-continue? prepare-for-consumer? build-postlude) (let-values ([(reg* reg-t* frame-t*) (get-arg-regs t1*)]) (let ([nfv* (fold-left (lambda (ls x) (cons (make-tmp 'nfv) ls)) '() frame-t*)] [cnfv* (fold-right (lambda (x ls) (cons (and (store-cp? x) (make-tmp 'cnfv)) ls)) '() tc*)] - [rpl* (map (lambda (tc) (make-local-label 'rpl)) tc*)] - [rpl (make-local-label 'rpl)]) + [rpl* (map (lambda (tc) (make-return-point-label 'rpl)) tc*)] + [rpl (make-return-point-label 'rpl)]) (let ([newframe-info (make-info-newframe (info-call-src info) (info-call-sexpr info) (reverse (remq #f cnfv*)) nfv* nfv**)]) (with-output-language (L13 Effect) (define build-return-point - (lambda (rpl mrvl cnfv* call) - (%seq (tail ,call) (label ,rpl) (return-point ,newframe-info ,rpl ,mrvl (,(remq #f cnfv*) ...))))) + (lambda (rpl mrvl mrvl-is-continue? cnfv* call) + (%seq (tail ,call) (label ,rpl) (return-point ,newframe-info ,rpl ,mrvl ,mrvl-is-continue? (,(remq #f cnfv*) ...))))) (define set-locs (lambda (loc* t* ebody) (fold-right @@ -11111,12 +11139,12 @@ `(seq ,e ,(prepare-for-consumer-call mrvl)) e)) (if (null? tc*) - (build-return-point rpl mrvl cnfv* + (build-return-point rpl mrvl mrvl-is-continue? cnfv* (build-call t0 rpl reg* nfv* info mdcl)) (let ([this-mrvl (make-local-label 'mrvl)]) `(seq ,(let ([rpl (car rpl*)]) - (build-return-point rpl this-mrvl cnfv* + (build-return-point rpl this-mrvl #f cnfv* (build-call t0 rpl reg* nfv* info mdcl))) ,(let f ([tc* tc*] [cnfv* cnfv*] [rpl* rpl*] [this-mrvl this-mrvl] [shift?* (info-call-shift-consumer-attachment?* info)]) @@ -11125,12 +11153,12 @@ ,(let ([tc (car tc*)] [tc* (cdr tc*)] [rpl* (cdr rpl*)] [cnfv (car cnfv*)] [cnfv* (cdr cnfv*)] [shift? (car shift?*)] [shift?* (cdr shift?*)]) (if (null? tc*) - (build-return-point rpl mrvl cnfv* + (build-return-point rpl mrvl mrvl-is-continue? cnfv* (build-consumer-call tc cnfv rpl shift?)) (let ([this-mrvl (make-local-label 'mrvl)]) `(seq ,(let ([rpl (car rpl*)]) - (build-return-point rpl this-mrvl cnfv* + (build-return-point rpl this-mrvl #f cnfv* (build-consumer-call tc cnfv rpl shift?))) ,(f tc* cnfv* rpl* this-mrvl shift?*))))))))))) ,(build-postlude newframe-info)))))))))))) @@ -11140,13 +11168,13 @@ (let-values ([(reg* reg-t* frame-t*) (get-arg-regs t1*)]) (let ([nfv* (fold-left (lambda (ls x) (cons (make-tmp 'nfv) ls)) '() frame-t*)] [cnfv* (fold-right (lambda (x ls) (cons (and (store-cp? x) (make-tmp 'cnfv)) ls)) '() tc*)] - [rpl* (map (lambda (tc) (make-local-label 'rpl)) (cdr tc*))] - [rpl (make-local-label 'rpl)]) + [rpl* (map (lambda (tc) (make-return-point-label 'rpl)) (cdr tc*))] + [rpl (make-return-point-label 'rpl)]) (let ([newframe-info (make-info-newframe (info-call-src info) (info-call-sexpr info) (reverse (remq #f cnfv*)) nfv* nfv**)]) (with-output-language (L13 Effect) (define build-return-point (lambda (rpl mrvl cnfv* call) - (%seq (tail ,call) (label ,rpl) (return-point ,newframe-info ,rpl ,mrvl (,(remq #f cnfv*) ...))))) + (%seq (tail ,call) (label ,rpl) (return-point ,newframe-info ,rpl ,mrvl #f (,(remq #f cnfv*) ...))))) (define set-locs (lambda (loc* t* ebody) (fold-right @@ -11243,7 +11271,7 @@ ,(build-consumer-call tc (in-context Triv (ref-reg %cp)) #f #f)) (let ([tc* (list-head tc* (fx- (length tc*) 1))]) `(seq - ,(build-nontail-call info mdcl t0 t1* tc* '() mrvl #t + ,(build-nontail-call info mdcl t0 t1* tc* '() mrvl #f #t (lambda (newframe-info) (%seq (remove-frame ,newframe-info) @@ -11267,13 +11295,11 @@ (%seq ; must leave RA in %ret for values-error (set! ,%ret ,(get-fv 0)) - (jump ,(%mref ,%ret ,(constant return-address-mv-return-address-disp)) - (,%ac0 ,%ret ,reg* ... ,fv* ...)))] + ,(%mv-jump ,%ret (,%ac0 ,%ret ,reg* ... ,fv* ...)))] [else (%seq (set! ,%xp ,(get-fv 0)) - (jump ,(%mref ,%xp ,(constant return-address-mv-return-address-disp)) - (,%ac0 ,reg* ... ,(get-fv 0) ,fv* ...)))]))))))))))) + ,(%mv-jump ,%xp (,%ac0 ,reg* ... ,(get-fv 0) ,fv* ...)))]))))))))))) (define-syntax do-return (lambda (x) (syntax-case x () @@ -11912,15 +11938,13 @@ [(real-register? '%ret) (%seq (set! ,%ret ,(%mref ,xp/cp ,(constant continuation-return-address-disp))) - (jump ,(%mref ,%ret ,(constant return-address-mv-return-address-disp)) - (,%ac0 ,%ret ,arg-registers ...)))] + ,(%mv-jump ,%ret (,%ac0 ,%ret ,arg-registers ...)))] [else (let ([fv0 (get-fv 0)]) (%seq (set! ,%xp ,(%mref ,xp/cp ,(constant continuation-return-address-disp))) (set! ,fv0 ,%xp) - (jump ,(%mref ,%xp ,(constant return-address-mv-return-address-disp)) - (,%ac0 ,arg-registers ... ,fv0))))])))))))))))) + ,(%mv-jump ,%xp (,%ac0 ,arg-registers ... ,fv0))))])))))))))))) (define reify-cc-help (lambda (1-shot? always? finish) (with-output-language (L13 Tail) @@ -12248,7 +12272,7 @@ (f (cdr x*)))))))] [(mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...)) (let ([mrvl (make-local-label 'mrvl)]) - (build-nontail-call info mdcl t0? t1* t* '() mrvl #f + (build-nontail-call info mdcl t0? t1* t* '() mrvl #t #f (lambda (newframe-info) (%seq (label ,mrvl) (remove-frame ,newframe-info) (restore-local-saves ,newframe-info)))))] [(mvset ,info (,mdcl ,t0? ,t1* ...) (,t* ...) ((,x** ...) ...) ,ebody) @@ -12260,12 +12284,12 @@ x*)) frame-x**)]) (let ([mrvl (make-local-label 'mrvl)]) - (build-nontail-call info mdcl t0? t1* t* nfv** mrvl #t + (build-nontail-call info mdcl t0? t1* t* nfv** mrvl #f #t (lambda (newframe-info) (fluid-let ([newframe-info-for-mventry-point newframe-info]) (Effect ebody))))))] [(set! ,[lvalue] (mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...))) - (build-nontail-call info mdcl t0? t1* t* '() #f #f + (build-nontail-call info mdcl t0? t1* t* '() #f #f #f (lambda (newframe-info) (let ([retval (make-tmp 'retval)]) (%seq @@ -12935,14 +12959,11 @@ (jump ,%ref-ret (,%ac0))) ,(meta-cond [(real-register? '%ret) - `(jump ,(%mref ,%ret ,(constant return-address-mv-return-address-disp)) - (,%ac0 ,%ret ,arg-registers ...))] + (%mv-jump ,%ret (,%ac0 ,%ret ,arg-registers ...))] [else (%seq (set! ,%xp ,%ref-ret) - (jump ,(%mref ,%xp - ,(constant return-address-mv-return-address-disp)) - (,%ac0 ,arg-registers ... ,(get-fv 0))))]))))] + ,(%mv-jump ,%xp (,%ac0 ,arg-registers ... ,(get-fv 0))))]))))] [($apply-procedure) (let ([Lloop (make-local-label 'loop)] [Ldone (make-local-label 'done)]) @@ -13740,8 +13761,8 @@ [(restore-local-saves ,info) (add-instr! target (with-output-language (L15a Effect) `(restore-local-saves ,(make-live-info) ,info))) (values target block*)] - [(return-point ,info ,rpl ,mrvl (,cnfv* ...)) - (add-instr! target (with-output-language (L15a Effect) `(return-point ,info ,rpl ,mrvl (,cnfv* ...)))) + [(return-point ,info ,rpl ,mrvl ,as-fallthrough (,cnfv* ...)) + (add-instr! target (with-output-language (L15a Effect) `(return-point ,info ,rpl ,mrvl ,as-fallthrough (,cnfv* ...)))) (block-return-point! target #t) (values target block*)] [(rp-header ,mrvl ,fs ,lpm) @@ -15023,7 +15044,7 @@ [(asm-return) (values (asm-return) chunk* offset)] [(asm-c-return ,info) (values (asm-c-return info) chunk* offset)] [(jump (label-ref ,l ,offset0)) - (values (asm-direct-jump l offset0) chunk* offset)] + (values (asm-direct-jump l (adjust-return-point-offset offset0 l)) chunk* offset)] [(jump (literal ,info)) (values (asm-literal-jump info) chunk* offset)] [(jump ,t) @@ -15085,7 +15106,8 @@ (let ([n (fx+ (constant code-data-disp) (constant size-rp-header) code-size)]) (lambda (ctrpi) (make-rp-info - (fx- n (local-label-offset (ctrpi-label ctrpi))) + (fx- n (fx- (local-label-offset (ctrpi-label ctrpi)) + (adjust-return-point-offset 0 (ctrpi-label ctrpi)))) (ctrpi-src ctrpi) (ctrpi-sexpr ctrpi) (ctrpi-mask ctrpi)))) @@ -15102,9 +15124,11 @@ (lambda (p) (c-trace (info-lambda-name info) code-size trace* p)))]) (Effect : Effect (ir code* chunk* offset) -> * (code* chunk* offset) [(rp-header ,mrvl ,fs ,lpm) (values (asm-rp-header code* mrvl fs lpm current-func #f) chunk* offset)] + [(rp-compact-header ,error-on-values ,fs ,lpm) (values (asm-rp-compact-header code* error-on-values fs lpm current-func #f) chunk* offset)] [(set! ,x (label-ref ,l ,offset1)) (guard (eq? (local-label-func l) current-func)) - (let ([chunk (make-chunk code*)]) + (let ([chunk (make-chunk code*)] + [offset1 (adjust-return-point-offset offset1 l)]) (let ([offset (fx+ (chunk-size chunk) offset)] [chunk* (cons chunk chunk*)]) (let ([chunk (asm-return-address x l offset1 offset)]) (values '() (cons chunk chunk*) (fx+ (chunk-size chunk) offset)))))] @@ -15130,7 +15154,7 @@ ($c-make-closure (local-label-func (info-literal-addr info))) `(,type ,(info-literal-addr info)))))] [(immediate ,imm) `(imm ,imm)] - [(label-ref ,l ,offset) (make-funcrel 'literal l offset)]) + [(label-ref ,l ,offset) (make-funcrel 'literal l (adjust-return-point-offset offset l))]) (Triv ir)) (define build-mem-opnd @@ -15163,6 +15187,14 @@ (ash 1 i)))) 0 i*))) + (define adjust-return-point-offset + (lambda (offset l) + (if (and (return-point-label? l) + (return-point-label-compact? l)) + (fx- offset (fx- (constant size-rp-header) + (constant size-rp-compact-header))) + offset))) + (architecture assembler) (import asm-module)) @@ -15889,13 +15921,21 @@ [(asm-c-return ,info ,reg* ...) `(asm-c-return ,info)]) (Effect : Effect (ir) -> Effect ()) (foldable-Effect : Effect (ir new-effect*) -> * (new-effect*) - [(return-point ,info ,rpl ,mrvl (,cnfv* ...)) + [(return-point ,info ,rpl ,mrvl ,as-fallthrough (,cnfv* ...)) (process-info-newframe! info) - (let ([lpm (build-live-pointer-mask (append cnfv* (info-newframe-call-live* info)))]) + (let* ([lpm (build-live-pointer-mask (append cnfv* (info-newframe-call-live* info)))] + [frame-words (info-newframe-frame-words info)] + [compact? (and (or as-fallthrough (not mrvl)) + (<= frame-words (constant compact-frame-max-words)))]) (record-inspector-info! (info-newframe-src info) (info-newframe-sexpr info) rpl (info-newframe-call-live* info) lpm) (with-output-language (L15b Effect) (safe-assert (< -1 lpm (ash 1 (fx- (info-newframe-frame-words info) 1)))) - (cons `(rp-header ,mrvl ,(fx* (info-newframe-frame-words info) (constant ptr-bytes)) ,lpm) new-effect*)))] + (cond + [compact? + (return-point-label-compact?-set! rpl #t) + (cons `(rp-compact-header ,(not mrvl) ,frame-words ,lpm) new-effect*)] + [else + (cons `(rp-header ,mrvl ,(fx* frame-words (constant ptr-bytes)) ,lpm) new-effect*)])))] [(remove-frame ,live-info ,info) (process-info-newframe! info) (with-output-language (L15b Effect) @@ -16259,6 +16299,7 @@ ; overflow-check counts as one instruction...close enough, since it rarely fails (nanopass-case (L15d Effect) e [(rp-header ,mrvl ,fs ,lpm) n] + [(rp-compact-header ,error-on-values ,fs ,lpm) n] [(move-related ,x1 ,x2) n] [else (fx+ n 1)]))) (if (generate-instruction-counts) @@ -16272,6 +16313,7 @@ (if (and (not (null? e*)) (nanopass-case (L15d Effect) (car e*) [(rp-header ,mrvl ,fs ,lpm) #t] + [(rp-compact-header ,error-on-values ,fs ,lpm) #t] [else #f])) (cons (car e*) (f (cdr e*))) (begin @@ -16293,6 +16335,8 @@ (handle-effect-inline effect-prim info new-effect* t* (live-info-live live-info))] [(rp-header ,mrvl ,fs ,lpm) (cons (with-output-language (L15d Effect) `(rp-header ,mrvl ,fs ,lpm)) new-effect*)] + [(rp-compact-header ,error-on-values ,fs ,lpm) + (cons (with-output-language (L15d Effect) `(rp-compact-header ,error-on-values ,fs ,lpm)) new-effect*)] [(overflow-check ,live-info) (if (fx> 1 overage (fx- (constant stack-frame-limit) (constant stack-slop))) (handle-overflow-check %sfp (intrinsic-info-asmlib dooverflow #f) new-effect* (live-info-live live-info)) diff --git a/s/inspect.ss b/s/inspect.ss index 14bae9f1ed..e75b34a62d 100644 --- a/s/inspect.ss +++ b/s/inspect.ss @@ -2503,8 +2503,15 @@ x*] [else (let* ([ret ($object-ref 'scheme-object frame 0)] - [size ($object-ref 'scheme-object ret (constant return-address-frame-size-disp))] - [livemask ($object-ref 'scheme-object ret (constant return-address-livemask-disp))] + [mask+size+mode ($object-ref 'iptr ret (constant compact-return-address-mask+size+mode-disp))] + [compact? (fxlogtest mask+size+mode (constant compact-header-mask))] + [size (if (not compact?) + ($object-ref 'scheme-object ret (constant return-address-frame-size-disp)) + (fxand (fxsrl mask+size+mode (constant compact-frame-words-offset)) + (constant compact-frame-words-mask)))] + [livemask (if (not compact?) + ($object-ref 'scheme-object ret (constant return-address-livemask-disp)) + (fxsrl mask+size+mode (constant compact-frame-mask-offset)))] [next-frame (fx- frame size)]) (let frame-loop ([p (fx+ next-frame 1)] [livemask livemask] [x* x*]) (if (eqv? livemask 0) diff --git a/s/library.ss b/s/library.ss index 9ec8805292..fea032614b 100644 --- a/s/library.ss +++ b/s/library.ss @@ -109,6 +109,9 @@ ((null? (cdr args)) (k (car args))) (else (#2%apply k args)))) ; library apply not available yet +;; before anything that returns multiple values +(define-hand-coded-library-entry values-error) + ;;; dounderflow & nuate must come before callcc (define-hand-coded-library-entry dounderflow) (define-hand-coded-library-entry nuate) @@ -126,7 +129,6 @@ (define-hand-coded-library-entry dofretu16*) (define-hand-coded-library-entry dofretu32*) (define-hand-coded-library-entry domvleterr) -(define-hand-coded-library-entry values-error) (define-hand-coded-library-entry bytevector=?) (define-hand-coded-library-entry $wrapper-apply) (define-hand-coded-library-entry wrapper-apply) diff --git a/s/mkheader.ss b/s/mkheader.ss index f113ac5e59..a1ba5ccad6 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -41,6 +41,7 @@ (fold-right (lambda (x rest) (case x [(#\-) (cons #\_ rest)] + [(#\+) (cons #\_ rest)] [(#\?) (cons #\p rest)] [(#\>) rest] [(#\*) (cons #\s rest)] @@ -970,6 +971,9 @@ (defref RPHEADERLIVEMASK rp-header livemask) (defref RPHEADERTOPLINK rp-header toplink) + (defref RPCOMPACTHEADERMASKANDSIZE rp-compact-header mask+size+mode) + (defref RPCOMPACTHEADERTOPLINK rp-compact-header toplink) + (nl) (comment "machine types") (pr "#define machine_type_names ") diff --git a/s/np-languages.ss b/s/np-languages.ss index c9e762fcd8..db94035509 100644 --- a/s/np-languages.ss +++ b/s/np-languages.ss @@ -70,6 +70,8 @@ local-label-trap-check local-label-trap-check-set! direct-call-label? make-direct-call-label direct-call-label-referenced direct-call-label-referenced-set! + return-point-label? make-return-point-label + return-point-label-compact? return-point-label-compact?-set! Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc lookup-primref primref? primref-level primref-name primref-flags primref-arity preinfo-src preinfo-sexpr preinfo-lambda-name preinfo-lambda-flags preinfo-lambda-libspec @@ -274,6 +276,16 @@ (lambda (name) ((pargs->new name) #f))))) + (define-record-type return-point-label + (parent local-label) + (nongenerative) + (sealed #t) + (fields (mutable compact?)) + (protocol + (lambda (pargs->new) + (lambda (name) + ((pargs->new name) #f))))) + (module () (define lookup-unique-label (let ([ht (make-eq-hashtable)]) @@ -297,6 +309,10 @@ (lambda (x) (or (eq? x #f) (label? x)))) + (define return-label? + (lambda (x) + (or (eq? x 'continue) (maybe-label? x)))) + ; language to replace prelex with uvar, create info records out of some of the complex ; records, and make sure other record types have been discarded. also formally sets up ; CaseLambdaClause as entry point for language. @@ -825,10 +841,11 @@ (immediate (imm fs)) (exact-integer (lpm)) (info (info)) - (maybe-label (mrvl)) + (return-label (mrvl)) (label (l rpl)) (source-object (src)) - (symbol (sym))) + (symbol (sym)) + (boolean (as-fallthrough))) (Program (prog) (labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l))) (CaseLambdaExpr (le) @@ -859,7 +876,7 @@ (overflood-check) (fcallable-overflow-check) (new-frame info rpl* ... rpl) - (return-point info rpl mrvl (cnfv* ...)) + (return-point info rpl mrvl as-fallthrough (cnfv* ...)) (rp-header mrvl fs lpm) (remove-frame info) (restore-local-saves info) @@ -956,7 +973,8 @@ (live-info (live-info)) (info (info)) (label (l rpl)) - (maybe-label (mrvl)) + (return-label (mrvl)) + (boolean (error-on-values as-fallthrough)) (fixnum (max-fv offset)) (block (block entry-block))) (Program (pgm) @@ -981,8 +999,9 @@ (overflow-check live-info) (overflood-check live-info) (fcallable-overflow-check live-info) - (return-point info rpl mrvl (cnfv* ...)) + (return-point info rpl mrvl as-fallthrough (cnfv* ...)) (rp-header mrvl fs lpm) + (rp-compact-header error-on-values fs lpm) (remove-frame live-info info) (restore-local-saves live-info info) (shift-arg live-info reg imm info) @@ -1005,7 +1024,7 @@ (Effect (e) (- (remove-frame live-info info) (restore-local-saves live-info info) - (return-point info rpl mrvl (cnfv* ...)) + (return-point info rpl mrvl as-fallthrough (cnfv* ...)) (shift-arg live-info reg imm info) (check-live live-info reg* ...)) (+ (fp-offset live-info imm))) diff --git a/s/ppc32.ss b/s/ppc32.ss index e9f39ef036..266f2d8c29 100644 --- a/s/ppc32.ss +++ b/s/ppc32.ss @@ -836,7 +836,8 @@ asm-logand asm-lognot asm-logtest asm-fl-relop asm-relop asm-logrelop asm-indirect-jump asm-literal-jump - asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header + asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label + asm-rp-header asm-rp-compact-header asm-indirect-call asm-condition-code asm-trunc asm-flt asm-lock asm-lock+/- asm-cas @@ -2119,21 +2120,41 @@ (let ([mrv-error `(abs ,(constant code-data-disp) (library-code ,(lookup-libspec values-error)))]) (lambda (code* mrvl fs lpm func code-size) - (cons* - (if (target-fixnum? lpm) - `(long . ,(fix lpm)) - `(abs 0 (object ,lpm))) - (aop-cons* `(asm livemask: ,(format "~b" lpm)) - '(code-top-link) - (aop-cons* `(asm code-top-link) - `(long . ,fs) - (aop-cons* `(asm "frame size:" ,fs) - (if mrvl - (asm-data-label code* mrvl 0 func code-size) - (cons* - mrv-error - (aop-cons* `(asm "mrv point:" ,mrv-error) - code*)))))))))) + (let* ([code* (cons* `(long . ,fs) + (aop-cons* `(asm "frame size:" ,fs) + code*))] + [code* (cons* (if (target-fixnum? lpm) + `(long . ,(fix lpm)) + `(abs 0 (object ,lpm))) + (aop-cons* `(asm livemask: ,(format "~b" lpm)) + code*))] + [code* (if mrvl + (asm-data-label code* mrvl 0 func code-size) + (cons* + mrv-error + (aop-cons* `(asm "mrv point:" ,mrv-error) + code*)))] + [code* (cons* + '(code-top-link) + (aop-cons* `(asm code-top-link) + code*))]) + code*)))) + + (define asm-rp-compact-header + (lambda (code* err? fs lpm func code-size) + (let* ([code* (cons* `(long . ,(fxior (constant compact-header-mask) + (if err? + (constant compact-header-values-error-mask) + 0) + (fxsll fs (constant compact-frame-words-offset)) + (fxsll lpm (constant compact-frame-mask-offset)))) + (aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue))) + code*))] + [code* (cons* + '(code-top-link) + (aop-cons* `(asm code-top-link) + code*))]) + code*))) (define asm-return (lambda () diff --git a/s/x86.ss b/s/x86.ss index 5f937ce9aa..02979489d0 100644 --- a/s/x86.ss +++ b/s/x86.ss @@ -937,7 +937,8 @@ asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate asm-pop asm-shiftop asm-sll asm-logand asm-lognot asm-logtest asm-fl-relop asm-relop asm-push asm-indirect-jump asm-literal-jump - asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header + asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label + asm-rp-header asm-rp-compact-header asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg @@ -2291,21 +2292,41 @@ (let ([mrv-error `(abs ,(constant code-data-disp) (library-code ,(lookup-libspec values-error)))]) (lambda (code* mrvl fs lpm func code-size) - (cons* - (if (target-fixnum? lpm) - `(long . ,(fix lpm)) - `(abs 0 (object ,lpm))) - (aop-cons* `(asm livemask: ,(format "~b" lpm)) - '(code-top-link) - (aop-cons* `(asm code-top-link) - `(long . ,fs) - (aop-cons* `(asm "frame size:" ,fs) - (if mrvl - (asm-data-label code* mrvl 0 func code-size) - (cons* - mrv-error - (aop-cons* `(asm "mrv point:" ,mrv-error) - code*)))))))))) + (let* ([code* (cons* `(long . ,fs) + (aop-cons* `(asm "frame size:" ,fs) + code*))] + [code* (cons* (if (target-fixnum? lpm) + `(long . ,(fix lpm)) + `(abs 0 (object ,lpm))) + (aop-cons* `(asm livemask: ,(format "~b" lpm)) + code*))] + [code* (if mrvl + (asm-data-label code* mrvl 0 func code-size) + (cons* + mrv-error + (aop-cons* `(asm "mrv point:" ,mrv-error) + code*)))] + [code* (cons* + '(code-top-link) + (aop-cons* `(asm code-top-link) + code*))]) + code*)))) + + (define asm-rp-compact-header + (lambda (code* err? fs lpm func code-size) + (let* ([code* (cons* `(long . ,(fxior (constant compact-header-mask) + (if err? + (constant compact-header-values-error-mask) + 0) + (fxsll fs (constant compact-frame-words-offset)) + (fxsll lpm (constant compact-frame-mask-offset)))) + (aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue))) + code*))] + [code* (cons* + '(code-top-link) + (aop-cons* `(asm code-top-link) + code*))]) + code*))) (constant-case machine-type-name [(i3osx ti3osx) diff --git a/s/x86_64.ss b/s/x86_64.ss index 6db9b7326c..76e36ef323 100644 --- a/s/x86_64.ss +++ b/s/x86_64.ss @@ -1019,7 +1019,8 @@ asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate asm-pop asm-shiftop asm-sll asm-logand asm-lognot asm-logtest asm-fl-relop asm-relop asm-push asm-indirect-jump asm-literal-jump - asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header + asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label + asm-rp-header asm-rp-compact-header asm-lea1 asm-lea2 asm-indirect-call asm-condition-code asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div asm-popcount asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg @@ -2563,21 +2564,42 @@ (library-code ,(lookup-libspec values-error)))]) (lambda (code* mrvl fs lpm func code-size) (let ([size (constant-case ptr-bits [(32) 'long] [(64) 'quad])]) - (cons* - (if (target-fixnum? lpm) - `(,size . ,(fix lpm)) - `(abs 0 (object ,lpm))) - (aop-cons* `(asm livemask: ,(format "~b" lpm)) - '(code-top-link) - (aop-cons* `(asm code-top-link) - `(,size . ,fs) - (aop-cons* `(asm "frame size:" ,fs) - (if mrvl - (asm-data-label code* mrvl 0 func code-size) - (cons* - mrv-error - (aop-cons* `(asm "mrv point:" ,mrv-error) - code*))))))))))) + (let* ([code* (cons* `(,size . ,fs) + (aop-cons* `(asm "frame size:" ,fs) + code*))] + [code* (cons* (if (target-fixnum? lpm) + `(,size . ,(fix lpm)) + `(abs 0 (object ,lpm))) + (aop-cons* `(asm livemask: ,(format "~b" lpm)) + code*))] + [code* (if mrvl + (asm-data-label code* mrvl 0 func code-size) + (cons* + mrv-error + (aop-cons* `(asm "mrv point:" ,mrv-error) + code*)))] + [code* (cons* + '(code-top-link) + (aop-cons* `(asm code-top-link) + code*))]) + code*))))) + + (define asm-rp-compact-header + (lambda (code* err? fs lpm func code-size) + (let ([size (constant-case ptr-bits [(32) 'long] [(64) 'quad])]) + (let* ([code* (cons* `(,size . ,(fxior (constant compact-header-mask) + (if err? + (constant compact-header-values-error-mask) + 0) + (fxsll fs (constant compact-frame-words-offset)) + (fxsll lpm (constant compact-frame-mask-offset)))) + (aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue))) + code*))] + [code* (cons* + '(code-top-link) + (aop-cons* `(asm code-top-link) + code*))]) + code*)))) (define-syntax asm-enter (lambda (x)