more compact return points for function calls
In the general form of a function call, the return point embeds 4 words of information: offset to the start of the enclosing function, frame size, live-veriable mask, and multiple-value return address. In the common case, however, the multiple-value return address is either the same as the return address or it is a `values-error` library function, and the frame size and live-variable mask fit into a word with bits to spare. This patch implements a more compact return point for that common case, which shrinks the 4 words to 2 and also avoids a relocation (= 1 more word). Multiple-value returns are more complex with this change (i.e., require more code), since they must check whether the return point is compact or not. But multiple-value returns are far less common than function calls, so saving function-call space is a clear win. Overall, this change tends to reduce code size by about 10% on x86_64. original commit: 1f53b5eabef966db01086cb32e544bbf8deacfca
This commit is contained in:
Matthew Flatt
parent
83f8acbfef
commit
26ff90e8e6
4
c/gc.c
4
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) {
|
||||
|
|
|
|||
19
c/types.h
19
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)))
|
||||
|
|
|
|||
9
configure
vendored
9
configure
vendored
|
|
@ -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=<machine type> explicitly specify machine type ($m)"
|
||||
echo " -m=<machine type> same as --machine <machine type> ($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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
39
s/arm32.ss
39
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)
|
||||
(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-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
`(long . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
(if mrvl
|
||||
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*)))]
|
||||
[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) '())))
|
||||
|
|
|
|||
36
s/cmacros.ss
36
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))])
|
||||
|
|
|
|||
144
s/cpnanopass.ss
144
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)
|
||||
(bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))])
|
||||
(build-fix
|
||||
(%inline -
|
||||
,(%mref
|
||||
,(%mref ,e ,(constant continuation-return-address-disp))
|
||||
,(constant return-address-toplink-disp))
|
||||
,(%constant return-address-toplink-disp)))])
|
||||
`(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
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
11
s/inspect.ss
11
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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 ")
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
39
s/ppc32.ss
39
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)
|
||||
(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-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
`(long . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
(if mrvl
|
||||
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*)))]
|
||||
[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 ()
|
||||
|
|
|
|||
39
s/x86.ss
39
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)
|
||||
(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-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
`(long . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
(if mrvl
|
||||
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*)))]
|
||||
[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)
|
||||
|
|
|
|||
40
s/x86_64.ss
40
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)
|
||||
(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-top-link)
|
||||
(aop-cons* `(asm code-top-link)
|
||||
`(,size . ,fs)
|
||||
(aop-cons* `(asm "frame size:" ,fs)
|
||||
(if mrvl
|
||||
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*)))]
|
||||
[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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user