cmucl-cvs

cmucl-cvs@common-lisp.net

2904 discussions

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-07-6-g5e57578
by Raymond Toy 18 Jul '12

18 Jul '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 5e57578ad6f1d02d86379986f79755e993ce2c72 (commit) via ea2dae80bcc9be55607ce8d9b62c268db53e98c5 (commit) from 5a06638f9d7e8309d4bb8eee49436489d5ce525f (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5e57578ad6f1d02d86379986f79755e993ce2c72 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Jul 17 19:35:23 2012 -0700 Fix possible stack corruption caused by possibly not allocating enough stack space to hold the SSE2 state. (Forgot to add extra bytes for 16-byte alignment!) diff --git a/src/lisp/x86-assem.S b/src/lisp/x86-assem.S index 34c1ef0..57b69c0 100644 --- a/src/lisp/x86-assem.S +++ b/src/lisp/x86-assem.S @@ -172,7 +172,11 @@ FUNCDEF(call_into_lisp) cmp $2, %eax # SSE2 mode? jne x87_save movl %esp, %eax # Remember the current stack pointer - subl $512,%esp # Make room for the SSE state + /* + * The SSE state is 512 bytes, but we need 16 more because we + * need 16-byte alignment. + */ + subl $512+16,%esp andl $-16, %esp # fxsave needs 16-byte alignment fxsave (%esp) pushl %eax # Save the old stack pointer @@ -194,7 +198,7 @@ x87_save: fldcw (%esp) # Recover modes popl %eax npx_save_done: - + /* Is this still necessary with sse2? */ fldz # insure no FP regs are empty fldz fldz commit ea2dae80bcc9be55607ce8d9b62c268db53e98c5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Jul 17 19:32:17 2012 -0700 Clean up and correct some comments. diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 21b68e4..ca2c267 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -140,22 +140,25 @@ (defun inline-allocation (alloc-tn size) (let ((ok (gen-label)) (done (gen-label))) - ;; + ;; Load the size first so that the size can be in the same ;; register as alloc-tn. (load-size alloc-tn alloc-tn size) - ;; + + ;; Try inline allocation, incrementing the + ;; current-region-free-pointer by the size. If we didn't pass the + ;; end of the region, then inline allocation succeeded, and we're + ;; done. (inst add alloc-tn (make-symbol-value-ea '*current-region-free-pointer*)) (inst cmp alloc-tn (make-symbol-value-ea '*current-region-end-addr*)) (inst jmp :be OK) - ;; Inline allocation didn't work so we need to call alloc, carefully. - - ;; Recompute the size. Can't just reload size because it might - ;; have already been destroyed if size = alloc-tn (which does - ;; happen). + ;; Inline allocation didn't work so we need to call alloc, + ;; carefully. Need to recompute the size because we can't just + ;; reload size because it might have already been destroyed if + ;; size = alloc-tn (which does happen). (inst sub alloc-tn (make-symbol-value-ea '*current-region-free-pointer*)) (case (tn-offset alloc-tn) (#.eax-offset @@ -169,7 +172,7 @@ (inst call (make-fixup (extern-alien-name #-sse2 "alloc_overflow_x87" #+sse2 "alloc_overflow_sse2") :foreign)) - (inst mov alloc-tn eax-tn) ; Save allocated address in alloc-tn + (inst mov alloc-tn eax-tn) ; Put allocated address in alloc-tn (inst pop eax-tn) ; Restore old value of eax (inst jmp done))) @@ -181,8 +184,7 @@ (values)) (defun not-inline-allocation (alloc-tn size) - ;; C call to allocate via dispatch routines. Each destination has a - ;; special entry point. The size may be a register or a constant. + ;; C call to allocate. The size may be a register or a constant. (load-size alloc-tn alloc-tn size) (case (tn-offset alloc-tn) (#.eax-offset diff --git a/src/lisp/x86-assem.S b/src/lisp/x86-assem.S index 9583e84..34c1ef0 100644 --- a/src/lisp/x86-assem.S +++ b/src/lisp/x86-assem.S @@ -484,7 +484,7 @@ FUNCDEF(alloc_overflow_sse2) movl %ecx, 8(%esp) # Save ecx and edx registers movl %edx, 4(%esp) stmxcsr 12(%esp) # Save MXCSR - /* Clear the exceptions that might occurred */ + /* Clear the exceptions that might have occurred */ movl 12(%esp), %edx and $-64, %edx # Clear the exceptions movl %edx, 16(%esp) ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/macros.lisp | 22 ++++++++++++---------- src/lisp/x86-assem.S | 10 +++++++--- 2 files changed, 19 insertions(+), 13 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-07-4-g5a06638
by Raymond Toy 17 Jul '12

17 Jul '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 5a06638f9d7e8309d4bb8eee49436489d5ce525f (commit) from 99020b36cd96dae59ba3638d01c69d18ee9edcd1 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5a06638f9d7e8309d4bb8eee49436489d5ce525f Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Jul 16 22:21:18 2012 -0700 Change url to www.cmucl.org. diff --git a/src/code/save.lisp b/src/code/save.lisp index 69d91fc..f06461f 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -357,7 +357,7 @@ (setf (getf *herald-items* :bugs) `(,#'(lambda (stream) - (write-string (intl:gettext "See <http://www.cons.org/cmucl/> for support information.") stream)) + (write-string (intl:gettext "See <http://www.cmucl.org/> for support information.") stream)) terpri ,#'(lambda (stream) (write-string (intl:gettext "Loaded subsystems:") stream)))) ----------------------------------------------------------------------- Summary of changes: src/code/save.lisp | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-07-3-g99020b3
by Raymond Toy 17 Jul '12

17 Jul '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 99020b36cd96dae59ba3638d01c69d18ee9edcd1 (commit) from f9f78a47c59d5cbe762a8a571b66b788b27e45ff (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 99020b36cd96dae59ba3638d01c69d18ee9edcd1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Jul 16 19:43:14 2012 -0700 Clean up not-inline-allocation. src/lisp/x86-assem.S: o Remove the (now) unused alloc_to_<reg> functions. src/compiler/x86/macros.lisp: o Simplify the not-inline-allocation to use the same routines as inline allocation. diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 9d955f4..21b68e4 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -183,31 +183,20 @@ (defun not-inline-allocation (alloc-tn size) ;; C call to allocate via dispatch routines. Each destination has a ;; special entry point. The size may be a register or a constant. - (ecase (tn-offset alloc-tn) + (load-size alloc-tn alloc-tn size) + (case (tn-offset alloc-tn) (#.eax-offset - (load-size alloc-tn eax-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_eax") + (inst call (make-fixup (extern-alien-name #-sse2 "alloc_overflow_x87" + #+sse2 "alloc_overflow_sse2") :foreign))) - (#.ecx-offset - (load-size alloc-tn ecx-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_ecx") - :foreign))) - (#.edx-offset - (load-size alloc-tn edx-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_edx") - :foreign))) - (#.ebx-offset - (load-size alloc-tn ebx-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_ebx") - :foreign))) - (#.esi-offset - (load-size alloc-tn esi-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_esi") - :foreign))) - (#.edi-offset - (load-size alloc-tn edi-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_edi") - :foreign)))) + (t + (inst push eax-tn) ; Save any value in eax + (inst mov eax-tn alloc-tn) + (inst call (make-fixup (extern-alien-name #-sse2 "alloc_overflow_x87" + #+sse2 "alloc_overflow_sse2") + :foreign)) + (inst mov alloc-tn eax-tn) ; Save allocated address in alloc-tn + (inst pop eax-tn))) (values)) ;;; diff --git a/src/lisp/x86-assem.S b/src/lisp/x86-assem.S index 46640fa..9583e84 100644 --- a/src/lisp/x86-assem.S +++ b/src/lisp/x86-assem.S @@ -459,101 +459,6 @@ ENDFUNC(fastcopy16) /* - Allocate bytes and return the start of the allocated space - in the specified destination register. - - In the general case the size will be in the destination register. - - All registers must be preserved except the destination. - The C conventions will preserve ebx, esi, edi, and ebp. - So only eax, ecx, and edx need special care here. */ - -FUNCDEF(alloc_to_eax) - STACK_PROLOGUE(12) - movl %ecx, 8(%esp) # Save ecx and edx as C could destroy them. - movl %edx, 4(%esp) - movl %eax, (%esp) # Push the size - call GNAME(alloc) - movl 4(%esp), %edx # Restore ecx and edx. - movl 8(%esp), %ecx - STACK_EPILOGUE - ret -ENDFUNC(alloc_to_eax) - -FUNCDEF(alloc_to_ecx) - STACK_PROLOGUE(12) - movl %eax, 8(%esp) # Save eax and edx as C could destroy them. - movl %edx, 4(%esp) - movl %ecx, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%ecx # setup the destination. - movl 4(%esp), %edx # Restore eax and edx. - movl 8(%esp), %eax - STACK_EPILOGUE - ret -ENDFUNC(alloc_to_ecx) - -FUNCDEF(alloc_to_edx) - STACK_PROLOGUE(12) - movl %eax, 8(%esp) # Save eax and ecx as C could destroy them. - movl %ecx, 4(%esp) - movl %edx, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%edx # setup the destination. - movl 4(%esp), %ecx # Restore eax and ecx. - movl 8(%esp), %eax - STACK_EPILOGUE - ret -ENDFUNC(alloc_to_edx) - -FUNCDEF(alloc_to_ebx) - STACK_PROLOGUE(16) - movl %eax, 12(%esp) # Save eax, ecx, and edx as C could destroy them. - movl %ecx, 8(%esp) - movl %edx, 4(%esp) - movl %ebx, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%ebx # setup the destination. - movl 4(%esp), %edx # Restore eax, ecx and edx. - movl 8(%esp), %ecx - movl 12(%esp), %eax - STACK_EPILOGUE - ret -ENDFUNC(alloc_to_ebx) - -FUNCDEF(alloc_to_esi) - STACK_PROLOGUE(16) - movl %eax, 12(%esp) # Save eax, ecx, and edx as C could destroy them. - movl %ecx, 8(%esp) - movl %edx, 4(%esp) - movl %esi, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%esi # setup the destination. - movl 4(%esp), %edx # Restore eax, ecx and edx. - movl 8(%esp), %ecx - movl 12(%esp), %eax - STACK_EPILOGUE - ret -ENDFUNC(alloc_to_esi) - -FUNCDEF(alloc_to_edi) - STACK_PROLOGUE(16) - movl %eax, 12(%esp) # Save eax, ecx, and edx as C could destroy them. - movl %ecx, 8(%esp) - movl %edx, 4(%esp) - movl %edi, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%edi # setup the destination. - movl 4(%esp), %edx # Restore eax, ecx and edx. - movl 8(%esp), %ecx - movl 12(%esp), %eax - STACK_EPILOGUE - ret -ENDFUNC(alloc_to_edi) - -#ifdef GENCGC - -/* * alloc_overflow_x87 and alloc_overflow_sse2 must not be called from * C because it doesn't follow C conventions. * @@ -595,8 +500,6 @@ FUNCDEF(alloc_overflow_sse2) ret ENDFUNC(alloc_overflow_sse2) -#endif /* GENCGC */ - #ifdef LINKAGE_TABLE /* Call into C code to resolve a linkage entry. The initial code in the ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/macros.lisp | 35 +++++---------- src/lisp/x86-assem.S | 97 ------------------------------------------ 2 files changed, 12 insertions(+), 120 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-07-2-gf9f78a4
by Raymond Toy 13 Jul '12

13 Jul '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via f9f78a47c59d5cbe762a8a571b66b788b27e45ff (commit) via 2e95a0bb1011de96626271d6c4e367a6a8e7a6a4 (commit) from 7933ebf6d092f5172db350473629155ff622c888 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f9f78a47c59d5cbe762a8a571b66b788b27e45ff Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Jul 12 20:49:43 2012 -0700 Remove old inline allocation function and corresponding assembly routines. diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 5f7c397..9d955f4 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -137,47 +137,6 @@ (unless (and (tn-p size) (location= alloc-tn size)) (inst mov dst-tn size))) -#+nil -(defun inline-allocation (alloc-tn size) - (let ((ok (gen-label))) - ;; - ;; Load the size first so that the size can be in the same - ;; register as alloc-tn. - (load-size alloc-tn alloc-tn size) - ;; - (inst add alloc-tn - (make-symbol-value-ea '*current-region-free-pointer*)) - (inst cmp alloc-tn - (make-symbol-value-ea '*current-region-end-addr*)) - (inst jmp :be OK) - ;; - ;; Dispatch to the appropriate overflow routine. There is a - ;; routine for each destination. - (ecase (tn-offset alloc-tn) - (#.eax-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_eax") - :foreign))) - (#.ecx-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_ecx") - :foreign))) - (#.edx-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_edx") - :foreign))) - (#.ebx-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_ebx") - :foreign))) - (#.esi-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_esi") - :foreign))) - (#.edi-offset - (inst call (make-fixup (extern-alien-name "alloc_overflow_edi") - :foreign)))) - (emit-label ok) - (inst xchg (make-symbol-value-ea '*current-region-free-pointer*) - alloc-tn)) - (values)) - -;;#+nil (defun inline-allocation (alloc-tn size) (let ((ok (gen-label)) (done (gen-label))) diff --git a/src/lisp/x86-assem.S b/src/lisp/x86-assem.S index 465ab39..46640fa 100644 --- a/src/lisp/x86-assem.S +++ b/src/lisp/x86-assem.S @@ -553,124 +553,6 @@ ENDFUNC(alloc_to_edi) #ifdef GENCGC -/* Called from lisp when an inline allocation overflows. - Every register except the result needs to be preserved. - We depend on C to preserve ebx, esi, edi, and ebp. - But where necessary must save eax, ecx, edx. */ - -/* This routine handles an overflow with eax=crfp+size. So the - size=eax-crfp. */ -FUNCDEF(alloc_overflow_eax) - STACK_PROLOGUE(12) - movl %ecx, 8(%esp) # Save ecx - movl %edx, 4(%esp) # Save edx - /* Calculate the size for the allocation. */ - subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%eax - movl %eax, (%esp) # Push the size - call GNAME(alloc) - movl 4(%esp), %edx # Restore edx. - movl 8(%esp), %ecx # Restore ecx. - STACK_EPILOGUE - addl $6,(%esp) # Adjust the return address to skip the next inst. - ret -ENDFUNC(alloc_overflow_eax) - -/* This routine handles an overflow with ecx=crfp+size. So the - size=ecx-crfp. */ -FUNCDEF(alloc_overflow_ecx) - STACK_PROLOGUE(12) - movl %eax, 8(%esp) # Save eax - movl %edx, 4(%esp) # Save edx - /* Calculate the size for the allocation. */ - subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%ecx - movl %ecx, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%ecx # setup the destination. - movl 4(%esp), %edx # Restore edx. - movl 8(%esp), %eax # Restore eax. - STACK_EPILOGUE - addl $6,(%esp) # Adjust the return address to skip the next inst. - ret -ENDFUNC(alloc_overflow_ecx) - -/* This routine handles an overflow with edx=crfp+size. So the - size=edx-crfp. */ -FUNCDEF(alloc_overflow_edx) - STACK_PROLOGUE(12) - movl %eax, 8(%esp) # Save eax - movl %ecx, 4(%esp) # Save ecx - /* Calculate the size for the allocation. */ - subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%edx - movl %edx, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%edx # setup the destination. - movl 4(%esp), %ecx # Restore ecx. - movl 8(%esp), %eax # Restore eax. - STACK_EPILOGUE - addl $6,(%esp) # Adjust the return address to skip the next inst. - ret -ENDFUNC(alloc_overflow_edx) - -/* This routine handles an overflow with ebx=crfp+size. So the - size=ebx-crfp. */ -FUNCDEF(alloc_overflow_ebx) - STACK_PROLOGUE(16) - movl %eax, 12(%esp) # Save eax - movl %ecx, 8(%esp) # Save ecx - movl %edx, 4(%esp) # Save edx - /* Calculate the size for the allocation. */ - subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%ebx - movl %ebx, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%ebx # setup the destination. - movl 4(%esp), %edx # Restore edx. - movl 8(%esp), %ecx # Restore ecx. - movl 12(%esp), %eax # Restore eax. - STACK_EPILOGUE - addl $6,(%esp) # Adjust the return address to skip the next inst. - ret -ENDFUNC(alloc_overflow_ebx) - -/* This routine handles an overflow with esi=crfp+size. So the - size=esi-crfp. */ -FUNCDEF(alloc_overflow_esi) - STACK_PROLOGUE(16) - movl %eax, 12(%esp) # Save eax - movl %ecx, 8(%esp) # Save ecx - movl %edx, 4(%esp) # Save edx - /* Calculate the size for the allocation. */ - subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%esi - movl %esi, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%esi # setup the destination. - movl 4(%esp), %edx # Restore edx. - movl 8(%esp), %ecx # Restore ecx. - movl 12(%esp), %eax # Restore eax. - STACK_EPILOGUE - addl $6,(%esp) # Adjust the return address to skip the next inst. - ret -ENDFUNC(alloc_overflow_esi) - -/* This routine handles an overflow with edi=crfp+size. So the - size=edi-crfp. */ -FUNCDEF(alloc_overflow_edi) - STACK_PROLOGUE(16) - movl %eax, 12(%esp) # Save eax - movl %ecx, 8(%esp) # Save ecx - movl %edx, 4(%esp) # Save edx - /* Calculate the size for the allocation. */ - subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%edi - movl %edi, (%esp) # Push the size - call GNAME(alloc) - movl %eax,%edi # setup the destination. - movl 4(%esp), %edx # Restore edx. - movl 8(%esp), %ecx # Restore ecx. - movl 12(%esp), %eax # Restore eax. - STACK_EPILOGUE - addl $6,(%esp) # Adjust the return address to skip the next inst. - ret -ENDFUNC(alloc_overflow_edi) - /* * alloc_overflow_x87 and alloc_overflow_sse2 must not be called from * C because it doesn't follow C conventions. @@ -703,7 +585,9 @@ FUNCDEF(alloc_overflow_sse2) movl %edx, 16(%esp) ldmxcsr 16(%esp) # Get new mxcsr value movl %eax, (%esp) # Put size on stack for first arg to alloc() + call GNAME(alloc) + movl 4(%esp), %edx # Restore edx and ecx registers. eax has the return value. movl 8(%esp), %ecx ldmxcsr 12(%esp) commit 2e95a0bb1011de96626271d6c4e367a6a8e7a6a4 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Jul 11 22:00:07 2012 -0700 Clean up alloc overflow routine. Cross-compile needed. src/bootfiles/20c/boot-2012-07-1-x86-cross.lisp: o X86 cross-compile script src/compiler/x86/macros.lisp: o New inline-allocation to call our new overflow routine. src/lisp/x86-assem.S: o New alloc_overflow routine. src/tools/cross-scripts/cross-x86-x86.lisp: o Export all symbols in VM that are external symbols in OLD-VM with the corresponding symbol name. diff --git a/src/bootfiles/20c/boot-2012-07-1-x86-cross.lisp b/src/bootfiles/20c/boot-2012-07-1-x86-cross.lisp new file mode 100644 index 0000000..d9a5a3e --- /dev/null +++ b/src/bootfiles/20c/boot-2012-07-1-x86-cross.lisp @@ -0,0 +1,8 @@ +;;; Bootstrap for building the 2012-08 snapshot from the 2012-07 +;;; snapshot. The inline allocation routines are changing. + +;;; Nothing fancy needed; just use do a simple cross-build-world using +;;; this as the script. +#+x86 +(load "target:tools/cross-scripts/cross-x86-x86") + diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 731bcf4..5f7c397 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -137,6 +137,7 @@ (unless (and (tn-p size) (location= alloc-tn size)) (inst mov dst-tn size))) +#+nil (defun inline-allocation (alloc-tn size) (let ((ok (gen-label))) ;; @@ -176,6 +177,50 @@ alloc-tn)) (values)) +;;#+nil +(defun inline-allocation (alloc-tn size) + (let ((ok (gen-label)) + (done (gen-label))) + ;; + ;; Load the size first so that the size can be in the same + ;; register as alloc-tn. + (load-size alloc-tn alloc-tn size) + ;; + (inst add alloc-tn + (make-symbol-value-ea '*current-region-free-pointer*)) + (inst cmp alloc-tn + (make-symbol-value-ea '*current-region-end-addr*)) + (inst jmp :be OK) + + ;; Inline allocation didn't work so we need to call alloc, carefully. + + ;; Recompute the size. Can't just reload size because it might + ;; have already been destroyed if size = alloc-tn (which does + ;; happen). + (inst sub alloc-tn (make-symbol-value-ea '*current-region-free-pointer*)) + (case (tn-offset alloc-tn) + (#.eax-offset + (inst call (make-fixup (extern-alien-name #-sse2 "alloc_overflow_x87" + #+sse2 "alloc_overflow_sse2") + :foreign)) + (inst jmp done)) + (t + (inst push eax-tn) ; Save any value in eax + (inst mov eax-tn alloc-tn) + (inst call (make-fixup (extern-alien-name #-sse2 "alloc_overflow_x87" + #+sse2 "alloc_overflow_sse2") + :foreign)) + (inst mov alloc-tn eax-tn) ; Save allocated address in alloc-tn + (inst pop eax-tn) ; Restore old value of eax + (inst jmp done))) + + (emit-label ok) + (inst xchg (make-symbol-value-ea '*current-region-free-pointer*) + alloc-tn) + (emit-label done)) + + (values)) + (defun not-inline-allocation (alloc-tn size) ;; C call to allocate via dispatch routines. Each destination has a ;; special entry point. The size may be a register or a constant. @@ -240,7 +285,7 @@ Result-TN." `(pseudo-atomic (allocation ,result-tn (pad-data-block ,size) ,inline) - (storew (logior (ash (1- ,size) vm:type-bits) ,type-code) ,result-tn) + (storew (logior (ash (1- ,size) vm::type-bits) ,type-code) ,result-tn) (inst lea ,result-tn (make-ea :byte :base ,result-tn :disp other-pointer-type)) ,@forms)) diff --git a/src/lisp/x86-assem.S b/src/lisp/x86-assem.S index 19be973..465ab39 100644 --- a/src/lisp/x86-assem.S +++ b/src/lisp/x86-assem.S @@ -671,7 +671,47 @@ FUNCDEF(alloc_overflow_edi) ret ENDFUNC(alloc_overflow_edi) -#endif +/* + * alloc_overflow_x87 and alloc_overflow_sse2 must not be called from + * C because it doesn't follow C conventions. + * + * On entry: + * %eax = bytes to allocate + * On exit: + * %eax = address + */ +FUNCDEF(alloc_overflow_x87) + STACK_PROLOGUE(12) + movl %ecx, 8(%esp) # Save ecx and edx registers + movl %edx, 4(%esp) + movl %eax, (%esp) # Put size on stack for first arg to alloc() + call GNAME(alloc) + movl 4(%esp), %edx # Restore edx and ecx registers. eax has the return value. + movl 8(%esp), %ecx + STACK_EPILOGUE + ret +ENDFUNC(alloc_overflow_x87) + +FUNCDEF(alloc_overflow_sse2) + STACK_PROLOGUE(20) + movl %ecx, 8(%esp) # Save ecx and edx registers + movl %edx, 4(%esp) + stmxcsr 12(%esp) # Save MXCSR + /* Clear the exceptions that might occurred */ + movl 12(%esp), %edx + and $-64, %edx # Clear the exceptions + movl %edx, 16(%esp) + ldmxcsr 16(%esp) # Get new mxcsr value + movl %eax, (%esp) # Put size on stack for first arg to alloc() + call GNAME(alloc) + movl 4(%esp), %edx # Restore edx and ecx registers. eax has the return value. + movl 8(%esp), %ecx + ldmxcsr 12(%esp) + STACK_EPILOGUE + ret +ENDFUNC(alloc_overflow_sse2) + +#endif /* GENCGC */ #ifdef LINKAGE_TABLE diff --git a/src/tools/cross-scripts/cross-x86-x86.lisp b/src/tools/cross-scripts/cross-x86-x86.lisp index aa4d84d..fa4e31c 100644 --- a/src/tools/cross-scripts/cross-x86-x86.lisp +++ b/src/tools/cross-scripts/cross-x86-x86.lisp @@ -46,6 +46,9 @@ (export 'vm::fixup-code-object "VM") (export 'vm::sanctify-for-execution "VM") +(do-external-symbols (sym "OLD-VM") + (export (intern (symbol-name sym) "VM") "VM")) + (load "target:tools/comcom") ;;; Load the new backend. ----------------------------------------------------------------------- Summary of changes: src/bootfiles/20c/boot-2012-07-1-x86-cross.lisp | 8 ++ src/compiler/x86/macros.lisp | 52 +++++---- src/lisp/x86-assem.S | 142 +++++----------------- src/tools/cross-scripts/cross-x86-x86.lisp | 3 + 4 files changed, 72 insertions(+), 133 deletions(-) create mode 100644 src/bootfiles/20c/boot-2012-07-1-x86-cross.lisp hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp annotated tag snapshot-2012-07 created. snapshot-2012-07
by Raymond Toy 08 Jul '12

08 Jul '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2012-07 has been created at e8c658f4cd3321c2deb738b5d29d8897b25feba7 (tag) tagging 7933ebf6d092f5172db350473629155ff622c888 (commit) replaces snapshot-2012-06 tagged by Raymond Toy on Sun Jul 8 10:34:28 2012 -0700 - Log ----------------------------------------------------------------- Snapshot 2012-07 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.11 (Darwin) iEYEABECAAYFAk/5xKsACgkQJ5IjUmgZO7K3yACePfl/sKMu1D6J7sEzFkBiJjqz WRsAnjPTrR+VI01LIuiYHpX6W/bmadvH =+zkg -----END PGP SIGNATURE----- Raymond Toy (5): Update to asdf 2.22. Testsuite for asdf, using 2012-06, passes fine. Change min_av_mem_age to be an int instead of double. No floating All VOPs that call allocation should save any live registers. Rearrange the fpu save/restore stuff to make it a bit simpler. Oops. Need to use long long's to compute the age in gen_av_mem_age(). ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-06-5-g7933ebf
by Raymond Toy 06 Jul '12

06 Jul '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 7933ebf6d092f5172db350473629155ff622c888 (commit) from 2daa0e7c547d718b19b8b7d5408d8cf0be35a861 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 7933ebf6d092f5172db350473629155ff622c888 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Jul 5 15:24:18 2012 -0700 Oops. Need to use long long's to compute the age in gen_av_mem_age(). diff --git a/src/lisp/gencgc.c b/src/lisp/gencgc.c index a14b714..fc095f8 100644 --- a/src/lisp/gencgc.c +++ b/src/lisp/gencgc.c @@ -659,7 +659,7 @@ gen_av_mem_age(int gen) if (generations[gen].bytes_allocated == 0) return 0; - return (((long) generations[gen].cum_sum_bytes_allocated) << MEM_AGE_SHIFT) / + return (((long long) generations[gen].cum_sum_bytes_allocated) << MEM_AGE_SHIFT) / generations[gen].bytes_allocated; } ----------------------------------------------------------------------- Summary of changes: src/lisp/gencgc.c | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-06-4-g2daa0e7
by Raymond Toy 05 Jul '12

05 Jul '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 2daa0e7c547d718b19b8b7d5408d8cf0be35a861 (commit) from f61034ab9eadb5f0e86c1d93930c2cc7e04835c3 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 2daa0e7c547d718b19b8b7d5408d8cf0be35a861 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Jul 5 08:48:31 2012 -0700 Rearrange the fpu save/restore stuff to make it a bit simpler. diff --git a/src/lisp/arch.h b/src/lisp/arch.h index 7de6665..b8ebf3f 100644 --- a/src/lisp/arch.h +++ b/src/lisp/arch.h @@ -32,6 +32,8 @@ extern lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, extern void fpu_save(void *); extern void fpu_restore(void *); +extern void sse_save(void *); +extern void sse_restore(void *); extern void arch_make_linkage_entry(long, void *, long); extern long arch_linkage_entry(unsigned long); diff --git a/src/lisp/gencgc.c b/src/lisp/gencgc.c index 1e20421..a14b714 100644 --- a/src/lisp/gencgc.c +++ b/src/lisp/gencgc.c @@ -664,14 +664,9 @@ gen_av_mem_age(int gen) } /* - * The verbose argument controls how much to print out: - * 0 for normal level of detail; 1 for debugging. + * Define macro to allocate a local array of the appropriate size + * where the fpu state can be stored. */ -void -print_generation_stats(int verbose) -{ - int i, gens; - #if defined(i386) || defined(__x86_64) #define FPU_STATE_SIZE 27 /* @@ -680,36 +675,73 @@ print_generation_stats(int verbose) * appropriate alignment. */ #define SSE_STATE_SIZE ((512+16)/4) - int fpu_state[FPU_STATE_SIZE]; - int sse_state[SSE_STATE_SIZE]; - extern void sse_save(void *); - extern void sse_restore(void *); +/* + * Just use the SSE size for both x87 and sse2 since the SSE size is + * enough for either. + */ +#define FPU_STATE(name) int name[SSE_STATE_SIZE]; + #elif defined(sparc) - /* - * 32 (single-precision) FP registers, and the FP state register. - * But Sparc V9 has 32 double-precision registers (equivalent to 64 - * single-precision, but can't be accessed), so we leave enough room - * for that. - */ +/* + * 32 (single-precision) FP registers, and the FP state register. + * But Sparc V9 has 32 double-precision registers (equivalent to 64 + * single-precision, but can't be accessed), so we leave enough room + * for that. + */ #define FPU_STATE_SIZE (((32 + 32 + 1) + 1)/2) - long long fpu_state[FPU_STATE_SIZE]; +#define FPU_STATE(name) long long name[FPU_STATE_SIZE]; #elif defined(DARWIN) && defined(__ppc__) #define FPU_STATE_SIZE 32 - long long fpu_state[FPU_STATE_SIZE]; +#define FPU_STATE(name0 long long name[FPU_STATE_SIZE]; #endif +void +save_fpu_state(void* state) +{ +#if defined(i386) || defined(__x86_64) + if (fpu_mode == SSE2) { + sse_save(state); + } else { + fpu_save(state); + } +#else + fpu_save(state); +#endif +} + +void +restore_fpu_state(void* state) +{ +#if defined(i386) || defined(__x86_64) + if (fpu_mode == SSE2) { + sse_restore(state); + } else { + fpu_restore(state); + } +#else + fpu_restore(state); +#endif +} + + +/* + * The verbose argument controls how much to print out: + * 0 for normal level of detail; 1 for debugging. + */ +void +print_generation_stats(int verbose) +{ + int i, gens; + + FPU_STATE(fpu_state); + /* * This code uses the FP instructions which may be setup for Lisp so * they need to the saved and reset for C. */ - fpu_save(fpu_state); -#if defined(i386) || defined(__x86_64) - if (fpu_mode == SSE2) { - sse_save(sse_state); - } -#endif + save_fpu_state(fpu_state); /* Number of generations to print out. */ if (verbose) @@ -763,12 +795,7 @@ print_generation_stats(int verbose) } fprintf(stderr, " Total bytes alloc=%ld\n", bytes_allocated); - fpu_restore(fpu_state); -#if defined(i386) || defined(__x86_64) - if (fpu_mode == SSE2) { - sse_restore(sse_state); - } -#endif + restore_fpu_state(fpu_state); } /* Get statistics that are kept "on the fly" out of the generation ----------------------------------------------------------------------- Summary of changes: src/lisp/arch.h | 2 + src/lisp/gencgc.c | 89 ++++++++++++++++++++++++++++++++++------------------ 2 files changed, 60 insertions(+), 31 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-06-3-gf61034a
by Raymond Toy 03 Jul '12

03 Jul '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via f61034ab9eadb5f0e86c1d93930c2cc7e04835c3 (commit) from 8a9d1d8d186004b5bd3354f2f9e0d0cc4b307d86 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f61034ab9eadb5f0e86c1d93930c2cc7e04835c3 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Jun 30 15:08:37 2012 -0700 All VOPs that call allocation should save any live registers. diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp index 85d95d1..bff6d0b 100644 --- a/src/compiler/x86/alloc.lisp +++ b/src/compiler/x86/alloc.lisp @@ -53,6 +53,7 @@ (:variant-vars star) (:policy :safe) (:node-var node) + (:save-p t) (:generator 0 (cond ((zerop num) ;; (move result nil-value) @@ -141,6 +142,7 @@ (:temporary (:sc unsigned-reg :from (:argument 0)) boxed) (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed) (:node-var node) + (:save-p t) (:generator 100 (move boxed boxed-arg) (inst add boxed (fixnumize (1+ code-trace-table-offset-slot))) @@ -169,6 +171,7 @@ (:args (name :scs (descriptor-reg) :to :eval)) (:results (result :scs (descriptor-reg) :from :argument)) (:node-var node) + (:save-p t) (:generator 37 (with-fixed-allocation (result fdefn-type fdefn-size node) (storew name result fdefn-name-slot other-pointer-type) @@ -182,6 +185,7 @@ (:args (name :scs (descriptor-reg) :to :eval)) (:results (result :scs (descriptor-reg) :from :argument)) (:node-var node) + (:save-p t) (:generator 37 (with-fixed-allocation (result fdefn-type fdefn-size node) (storew name result fdefn-name-slot other-pointer-type) @@ -196,6 +200,7 @@ (:temporary (:sc any-reg) temp) (:results (result :scs (descriptor-reg))) (:node-var node) + (:save-p t) (:generator 10 (let ((*enable-pseudo-atomic* (unless dynamic-extent *enable-pseudo-atomic*))) @@ -215,6 +220,7 @@ (:args (value :scs (descriptor-reg any-reg) :to :result)) (:results (result :scs (descriptor-reg) :from :eval)) (:node-var node) + (:save-p t) (:generator 10 (with-fixed-allocation (result value-cell-header-type value-cell-size node) @@ -236,6 +242,7 @@ (:ignore name) (:results (result :scs (descriptor-reg))) (:node-var node) + (:save-p t) (:generator 50 (let ((*enable-pseudo-atomic* (unless dynamic-extent *enable-pseudo-atomic*))) @@ -254,6 +261,7 @@ (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes) (:temporary (:sc any-reg :from :eval :to :result) header) (:node-var node) + (:save-p t) (:generator 50 (inst lea bytes (make-ea :dword :base extra :disp (* (1+ words) word-bytes))) @@ -279,6 +287,7 @@ (:temporary (:sc unsigned-reg :from :eval) state-addr) (:results (result :scs (descriptor-reg) :from :argument)) (:node-var node) + (:save-p t) (:generator 37 (with-fixed-allocation (result symbol-header-type symbol-size node) (storew name result symbol-name-slot other-pointer-type) diff --git a/src/compiler/x86/array.lisp b/src/compiler/x86/array.lisp index ae86e43..79b3ad1 100644 --- a/src/compiler/x86/array.lisp +++ b/src/compiler/x86/array.lisp @@ -35,6 +35,7 @@ (:temporary (:sc any-reg :to :result) header) (:results (result :scs (descriptor-reg) :from :eval)) (:node-var node) + (:save-p t) (:generator 13 (inst lea bytes (make-ea :dword :base rank diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 63104de..d0188c9 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1365,6 +1365,7 @@ (:temporary (:sc unsigned-reg) dst) (:results (result :scs (descriptor-reg))) (:node-var node) + (:save-p t) (:generator 20 (let ((enter (gen-label)) (loop (gen-label)) diff --git a/src/compiler/x86/float-sse2.lisp b/src/compiler/x86/float-sse2.lisp index f54f072..9fe6d5d 100644 --- a/src/compiler/x86/float-sse2.lisp +++ b/src/compiler/x86/float-sse2.lisp @@ -413,6 +413,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:single-float-type vm:single-float-size node) (inst movss (ea-for-sf-desc y) x)))) @@ -424,6 +425,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:double-float-type vm:double-float-size node) (inst movsd (ea-for-df-desc y) x)))) @@ -436,6 +438,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:long-float-type vm:long-float-size node) (with-tn@fp-top(x) @@ -498,6 +501,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"complex float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:complex-single-float-type vm:complex-single-float-size node) @@ -510,6 +514,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"complex float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:complex-double-float-type vm:complex-double-float-size node) @@ -524,6 +529,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"complex float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:complex-long-float-type vm:complex-long-float-size node) @@ -543,6 +549,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"complex double-double float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm::complex-double-double-float-type vm::complex-double-double-float-size node) @@ -1563,6 +1570,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"double double float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:double-double-float-type vm:double-double-float-size node) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index e4d5952..e0e90b0 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -498,6 +498,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:single-float-type vm:single-float-size node) (with-tn@fp-top(x) @@ -510,6 +511,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:double-float-type vm:double-float-size node) (with-tn@fp-top(x) @@ -523,6 +525,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:long-float-type vm:long-float-size node) (with-tn@fp-top(x) @@ -601,6 +604,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"complex float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:complex-single-float-type vm:complex-single-float-size node) @@ -618,6 +622,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"complex float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:complex-double-float-type vm:complex-double-float-size node) @@ -636,6 +641,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"complex float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:complex-long-float-type vm:complex-long-float-size node) @@ -655,6 +661,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"complex double-double float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm::complex-double-double-float-type vm::complex-double-double-float-size node) @@ -5054,6 +5061,7 @@ (:results (y :scs (descriptor-reg))) (:node-var node) (:note _N"double double float to pointer coercion") + (:save-p t) (:generator 13 (with-fixed-allocation (y vm:double-double-float-type vm:double-double-float-size node) diff --git a/src/compiler/x86/move.lisp b/src/compiler/x86/move.lisp index 2ff54ee..7c6f0b9 100644 --- a/src/compiler/x86/move.lisp +++ b/src/compiler/x86/move.lisp @@ -300,6 +300,7 @@ (:results (y :scs (any-reg descriptor-reg) :from :argument)) (:note _N"signed word to integer coercion") (:node-var node) + (:save-p t) (:generator 20 (assert (not (location= x y))) (let ((bignum (gen-label)) @@ -348,6 +349,7 @@ (:results (y :scs (any-reg descriptor-reg))) (:node-var node) (:note _N"unsigned word to integer coercion") + (:save-p t) (:generator 20 (assert (not (location= x y))) (assert (not (location= x alloc))) diff --git a/src/compiler/x86/sap.lisp b/src/compiler/x86/sap.lisp index a01112e..43e1a0e 100644 --- a/src/compiler/x86/sap.lisp +++ b/src/compiler/x86/sap.lisp @@ -44,6 +44,7 @@ (:results (res :scs (descriptor-reg) :from :argument)) (:note "SAP to pointer coercion") (:node-var node) + (:save-p t) (:generator 20 (with-fixed-allocation (res sap-type sap-size node) (storew sap res sap-pointer-slot other-pointer-type)))) ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/alloc.lisp | 9 +++++++++ src/compiler/x86/array.lisp | 1 + src/compiler/x86/call.lisp | 1 + src/compiler/x86/float-sse2.lisp | 8 ++++++++ src/compiler/x86/float.lisp | 8 ++++++++ src/compiler/x86/move.lisp | 2 ++ src/compiler/x86/sap.lisp | 1 + 7 files changed, 30 insertions(+), 0 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch tcall-convention created. snapshot-2012-06-54-g6bc8fe2
by Raymond Toy 29 Jun '12

29 Jun '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, tcall-convention has been created at 6bc8fe2052dbaa69ed9a5ce6c545f61e45ceb0a0 (commit) - Log ----------------------------------------------------------------- commit 6bc8fe2052dbaa69ed9a5ce6c545f61e45ceb0a0 Merge: 8a35f22 eac8d34 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Jun 24 09:46:32 2012 -0700 Merge branch 'tcall-convention' of https://github.com/ellerh/cmucl into tcall-convention commit eac8d34cd595ff061f3cebae78ad8dab4d5f1cc4 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:41:24 2012 +0200 Remove TYPED-CALL-LOCAL vop. The XEP no longer calls the unboxed entry point, so we don't this kind of local call anymore. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 865b6e1..d58d113 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1760,8 +1760,7 @@ "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" - "TYPED-CALL-LOCAL" "TYPED-CALL-NAMED" - "TYPED-ENTRY-POINT-ALLOCATE-FRAME" + "TYPED-CALL-NAMED" "TYPED-ENTRY-POINT-ALLOCATE-FRAME" "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNWIND" "UWP-ENTRY" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST" diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index a255ddc..360f7c6 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -903,29 +903,6 @@ compilation policy") (move-continuation-result node block locs cont))))) (undefined-value)) -(defun ir2-convert-local-typed-call (node block fun cont) - (declare (type node node) (type ir2-block block) (type clambda fun) - (type continuation cont)) - (let ((ftype (the function-type (lambda-type fun))) - (args (basic-combination-args node)) - (start (getf (lambda-plist fun) :code-start))) - (multiple-value-bind (arg-tns result-tns - fp stack-frame-size - nfp number-stack-frame-size) - (make-typed-call-tns ftype) - (declare (ignore number-stack-frame-size)) - (collect ((actuals) (arg-locs)) - (loop for arg in args for loc in arg-tns do - (when arg - (actuals (continuation-tn node block arg)) - (arg-locs loc))) - (vop allocate-frame node block nil fp nfp) - (vop* typed-call-local node block - (fp nfp (reference-tn-list (actuals) nil)) - ((reference-tn-list result-tns t)) - (arg-locs) stack-frame-size start) - (move-continuation-result node block result-tns cont))))) - ;;; IR2-Convert-Local-Call -- Internal ;;; ;;; Dispatch to the appropriate function, depending on whether we have a @@ -953,13 +930,8 @@ compilation policy") (:unknown (ir2-convert-local-unknown-call node block fun cont start)) (:fixed - (ecase (getf (lambda-plist fun) :entry-point) - ((nil) - (ir2-convert-local-known-call node block fun returns - cont start)) - (:typed - (assert (external-entry-point-p (node-home-lambda node))) - (ir2-convert-local-typed-call node block fun cont))))))))) + (ir2-convert-local-known-call node block fun returns + cont start))))))) (undefined-value)) diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 63a8d07..7ebe917 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -761,37 +761,6 @@ (note-this-location vop :known-return) (trace-table-entry trace-table-normal))) - -(define-vop (typed-call-local) - (:args (new-fp) - (new-nfp) - (args :more t)) - (:results (results :more t)) - (:save-p t) - (:move-args :local-call) - (:vop-var vop) - (:info arg-locs real-frame-size target) - (:ignore new-nfp args arg-locs results) - (:generator 30 - ;; FIXME: allocate the real frame size here. We had to emit - ;; ALLOCATE-FRAME before this vop so that we can use the - ;; (:move-args :local-call) option here. Without the - ;; ALLOCATE-FRAME vop we get a failed assertion. - (inst lea esp-tn (make-ea :dword :base new-fp - :disp (- (* real-frame-size word-bytes)))) - - ;; Write old frame pointer (epb) into new frame. - (storew ebp-tn new-fp (- (1+ ocfp-save-offset))) - - ;; Switch to new frame. - (move ebp-tn new-fp) - - (note-this-location vop :call-site) - - (inst call target) - - )) - ;;; Return from known values call. We receive the return locations as ;;; arguments to terminate their lifetimes in the returning function. We commit c0fccaf11debb5d8de1c805199a6c3dcdc8682a3 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:32:50 2012 +0200 New file with tests for the unboxed calling convention. diff --git a/src/tests/unboxed-convention.lisp b/src/tests/unboxed-convention.lisp new file mode 100644 index 0000000..510968b --- /dev/null +++ b/src/tests/unboxed-convention.lisp @@ -0,0 +1,335 @@ +;; Tests for typed calling convention. + +(eval-when (:compile-toplevel) + (setq c::*check-consistency* t)) + +(in-package :cl-user) + +(defun fid (x) + (declare (double-float x) + (c::calling-convention :typed) + ) + x) + +(defun test-fid-1 () + (assert (= (fid 1d0) 1d0))) + +(defun f+ (x y) + (declare (double-float x y) + (c::calling-convention :typed)) + (+ x y)) + +(defun sum-prod (x y z u v w) + (declare (double-float x y z u v w) + (c::calling-convention :typed)) + (values (+ x y z u v w) + (* x y z u v w))) + +(defun test-sum-prod-1 () + (multiple-value-bind (sum prod) (sum-prod 2d0 3d0 4d0 5d0 6d0 7d0) + (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0))) + (assert (= prod (* 2d0 3d0 4d0 5d0 6d0 7d0))))) + +(defun test-sum-prod-2 () + (multiple-value-bind (sum) (sum-prod 2d0 3d0 4d0 5d0 6d0 7d0) + (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0))))) + +(defun test-sum-prod-3-aux (x y z u v w) + (sum-prod x y z u v w)) + +(defun test-sum-prod-3 () + (multiple-value-bind (sum prod) (test-sum-prod-3-aux 2d0 3d0 4d0 5d0 6d0 7d0) + (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0))) + (assert (= prod (* 2d0 3d0 4d0 5d0 6d0 7d0))))) + +(defun id (x) + (declare (c::calling-convention :typed)) + x) + +(defun test-id-1 () + (assert (eql (id 1) 1))) + +(defun test-id-2 () + (assert (eql (id 1d0) 1d0))) + +(defun test-id-3 () + (assert (equal (multiple-value-list (id 1d0)) '(1d0)))) + +;; This one has both boxed and unboxed arguments. +(defun cons-sum (o1 f1 o2 f2) + (declare (double-float f1 f2) + (c::calling-convention :typed)) + (values (cons o1 o2) (+ f1 f2))) + +(defun test-cons-sum-1 () + (multiple-value-bind (cons sum) (cons-sum 1 2d0 3 4d0) + (assert (equal cons '(1 . 3))) + (assert (= sum (+ 2d0 4d0))))) + +(defun ffib (x) + (declare (double-float x) + (c::calling-convention :typed)) + (the double-float + (cond ((= x 0) 0d0) + ((= x 1) 1d0) + (t (+ (ffib (- x 1)) + (ffib (- x 2))))))) + +;; (time (ffib 30d0)) + +(defun test-ffib-1 () + (assert (= (ffib 0d0) 0)) + (assert (= (ffib 1d0) 1)) + (assert (= (ffib 2d0) 1)) + (assert (= (ffib 3d0) 2)) + (assert (= (ffib 4d0) 3)) + (assert (= (ffib 5d0) 5)) + (assert (= (ffib 6d0) 8)) + (assert (= (ffib 7d0) 13)) + (assert (= (ffib 8d0) 21))) + +;; (test-ffib-1) + + +;; SUM will be redefined with different types to exercise the linker a +;; bit. +(defun sum (f1 f2) + (declare (double-float f1 f2) + (c::calling-convention :typed)) + (+ f1 f2)) + +(defun test-sum-1 () + (assert (= (sum 2d0 3d0) 5d0))) + +(defun sum (f1 f2) + (declare (c::calling-convention :typed)) + (+ f1 f2)) + +(defun test-sum-2 () + (assert (= (sum 2d0 3d0) 5d0))) + +(defun test-sum-3 () + (handler-case (progn (sum 2 3) + (assert nil)) + (type-error (c) + (assert (equal (type-error-datum c) 3)) + (assert (eq (type-error-expected-type c) 'double-float))))) + +(defun sum (f1 f2) + (declare (double-float f2) + (c::calling-convention :typed)) + (the double-float + (+ f1 f2))) + +(defun test-sum-4 () + (assert (= (sum 2d0 3d0) 5d0))) + +(defun test-sum-5 () + (assert (= (sum 2 3d0) 5d0))) + +(defun test-sum-6 () + (handler-case (progn + (sum #c(0 1) 3d0) + (assert nil)) + (type-error (c) + (assert (equal (type-error-datum c) #c(3d0 1d0))) + (assert (eq (type-error-expected-type c) 'double-float))))) + +(defun sum (f1 f2) + (declare (double-float f2)) + (the double-float + (+ f1 f2))) + +(defun test-sum-7 () + (assert (= (sum 2 3d0) 5d0))) + +;; (ext:info function kernel::linkage 'sum) + +(defun wild (f x y) + (declare (type function f) + (double-float x y) + (c::calling-convention :typed)) + (funcall f x y)) + +(defun test-wild-1 () + (assert (= (wild #'+ 3d0 5d0) 8d0))) + +(defun test-wild-2 () + (assert (equal (multiple-value-list (wild #'values 3d0 5d0)) + '(3d0 5d0)))) + + +(defun opt-result (x y) + (declare (double-float x y) + (c::calling-convention :typed)) + (if (zerop x) + y + (values x y))) + +(defun test-opt-result-1 () + (assert (= (opt-result 0d0 3d0) 3d0))) + +(defun test-opt-result-2 () + (assert (= (opt-result 1d0 3d0) 1d0))) + +(defun test-opt-result-3 () + (assert (equal (multiple-value-list (opt-result 1d0 3d0)) + '(1d0 3d0)))) + +(defun test-opt-result-3 () + (assert (equal (multiple-value-list (opt-result 0d0 3d0)) + '(3d0)))) + +;;(defun opt-arg (x &optional (y 0d0)) +;; (declare (double-float x y) +;; (c::calling-convention :typed)) +;; (+ x y)) + +(declaim (inline inlined-fun)) +(defun inlined-fun (obj) + (declare (c::calling-convention :typed)) + obj) + +(defun test-inlined-fun-1 () + (assert (eq (inlined-fun 'x) 'x))) + +(defun unused-arg-fun (x) + (declare (ignore x)) + (declare (c::calling-convention :typed)) + nil) + +(defun test-unused-arg-fun-1 () + (assert (eq (unused-arg-fun 'x) nil))) + +(let ((state 0)) + (defun closure () + (declare (c::calling-convention :typed)) + (mod (incf state) 2))) + +(defun test-closure-1 () + (assert (member (closure) '(0 1))) + (assert (member (closure) '(0 1)))) + +(defun self-ref () + (declare (c::calling-convention :typed)) + #'self-ref) + +(defun test-self-ref-1 () + (assert (eq #'self-ref (funcall (self-ref))))) + +(defun many-args (a b c d e f g h i j k l m n o p) + (declare (c::calling-convention :typed)) + (list a b c d e f g h i j k l m n o p)) + +(defun test-many-args-1 () + (assert (equal (many-args 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o 'p) + '(a b c d e f g h i j k l m n o p)))) + +;; (compile-file "/tmp/x.lisp" :trace-file "/tmp/x.trace" :progress t) + + +(defun many-results (a b c d e f g h i j k l m n o p) + (declare (c::calling-convention :typed)) + (values m n o p a b c d e f g h i j k l)) + +(defun test-many-results-1 () + (assert (equal (multiple-value-list + (many-results + 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o 'p)) + '(m n o p a b c d e f g h i j k l)))) + +#+(or) +(defun pcl::pcl-funcallable-instance-slots (object) + (declare ;;(type pcl::pcl-funcallable-instance object) + (c::calling-convention :typed)) + (kernel:%funcallable-instance-info object 0)) + +;; (c::clear-info function c::calling-convention 'pcl::pcl-funcallable-instance-slots) + +;; (c::info function calling-convention 'pcl::pcl-funcallable-instance-slots) + +(defun 6args (a b c d e f g) + (declare (c::calling-convention :typed)) + (list a b c d e f g)) + +(defun set-arg () + (let (a) + (setq a nil) + (6args nil nil nil a a a nil))) + +(defun 2values () + (declare (c::calling-convention :typed)) + (values 1 2)) + +(defun call-1-or-2-values (x) + (declare (c::calling-convention :typed)) + (or x + (2values))) + + +(defun test-call-1-or-2-values-1 () + (assert (equal (multiple-value-list (call-1-or-2-values 1)) + '(1)))) + +(defun test-call-1-or-2-values-2 () + (assert (equal (multiple-value-list (call-1-or-2-values nil)) + '(1 2)))) + +(defun deleted-fun (x) + (labels ((d () + (declare (c::calling-convention :typed)))) + #'d + x)) + +(defun gf-fun (x) + (declare (c::calling-convention :typed)) + x) + +;;(defun call-gf-fun (x) +;; (gf-fun x)) +;; +;;(defgeneric gf-fun (x)) +;;(defmethod gf-fun (x) +;; x) + + +#+(or) +(defun foo () + (labels ((sum (x y) (+ x y))) + (declare (ftype (function (double-float double-float) double-float) sum)) + (list (sum 2d0 4d0) + (sum 2 4)))) + +(defun tests () + (test-fid-1) + (test-sum-prod-1) + (test-sum-prod-2) + (test-sum-prod-3) + (test-id-1) + (test-id-2) + (test-id-3) + (test-cons-sum-1) + (test-ffib-1) + (test-sum-1) + (test-sum-2) + (test-sum-3) + (test-sum-4) + (test-sum-5) + (test-sum-6) + (test-sum-7) + (test-wild-1) + (test-wild-2) + (test-opt-result-1) + (test-opt-result-2) + (test-opt-result-3) + (test-inlined-fun-1) + (test-unused-arg-fun-1) + (test-closure-1) + (test-self-ref-1) + (test-many-args-1) + (test-many-results-1) + (test-call-1-or-2-values-1) + (test-call-1-or-2-values-2) + ) + +;; (tests) commit b7023422cee56e3f90d88a6c961bc7160879401c Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:20:15 2012 +0200 Be more careful when creating adapters. * code/fdefinition.lisp (generate-adapter-function): Simply use :typed convention instead of the :typed-no-xep. I removed :typed-no-xep as it was probably a premature optimisation. Also switch directly to full-call convention instead of trying to stay with typed convention. (check-function-redefinition): Handle the case when the new function doesn't have a typed entry point. diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 61725e6..e36e214 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -398,13 +398,14 @@ nil `(lambda ,tmps (declare - (c::calling-convention :typed-no-xep) + (c::calling-convention :typed) ,@(loop for tmp in tmps for type in atypes collect `(type ,(kernel:type-specifier type) ,tmp))) (the ,(kernel:type-specifier (kernel:function-type-returns ftype)) - (funcall (function ,name) . ,tmps)))))) + (funcall ',name . ,tmps))))) + (fun (find-typed-entry-point-for-function fun nil))) (validate-adapter-type fun ftype) fun)) @@ -475,7 +476,8 @@ (dolist (cs (listify (linkage-callsites linkage))) (let ((cs-type (callsite-type cs)) (fdefn (callsite-fdefn cs))) - (cond ((function-types-compatible-p cs-type new-type) + (cond ((and new-tep + (function-types-compatible-p cs-type new-type)) (patch-fdefn fdefn new-tep)) ((dolist (fun (listify (linkage-adapters linkage))) (let ((ep-type (kernel:extract-function-type fun))) commit 129c095c35fb5233c48795b5defe85d5c3427b81 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:14:59 2012 +0200 For typed-call-named force new-fp into register. We use the lea instruction so new-fp needs to be in a register. diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 6a0b59f..63a8d07 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1150,7 +1150,7 @@ (define-vop (typed-call-named) - (:args (new-fp) + (:args (new-fp :scs (any-reg) :to (:argument 1)) (new-nfp) (fdefn :scs (descriptor-reg control-stack) :target eax) commit 972472c0ccc627d7003b72105a50d505626812d1 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:12:45 2012 +0200 Lift restriction on number of return values. Apparently we can return values on the stack just fine. Don't allow ftypes with function-type-wild-args. diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index d7dd473..6a0b59f 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -228,17 +228,14 @@ (arg-tn (type state) (cond ((double-float-type-p type) (double-float-arg state)) (t (boxed-arg state)))) - (ret-tn (type state) - (let ((tn (arg-tn type state))) - (assert (member (sc-name (tn-sc tn)) - '(double-reg descriptor-reg))) - tn))) + (ret-tn (type state) (arg-tn type state))) (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0))) (values (multiple-value-bind (min max) (function-type-nargs ftype) (assert (and min max (= min max)) () "Only fixed number of arguments supported (currently)") + (assert (not (function-type-wild-args ftype))) (loop for type in (function-type-required ftype) collect (arg-tn type arg-state))) (multiple-value-bind (types count) commit 7fdc7377e601a50e3f8085417881b99667c8ac6a Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:10:41 2012 +0200 Fix off-by-one error when choosing argument registers. * compiler/x86/call.lisp (make-typed-call-tns): Use < not <= when comparing with register-arg-count. diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index cad0b46..d7dd473 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -212,7 +212,7 @@ (prog1 (getf state :frame-size) (incf (getf state :frame-size) 2)))))) (boxed-arg (state) - (cond ((<= (getf state :reg-args) register-arg-count) + (cond ((< (getf state :reg-args) register-arg-count) (let ((n (getf state :reg-args))) (incf (getf state :reg-args)) (x86-standard-argument-location n))) commit ecd220e44f71fa92c571adce2da2a0ffcd2fc6d1 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:10:02 2012 +0200 Handle multiple-value-call with fixed numer of values. * compiler/ir2tran.lisp (%typed-call-ir2-convert-optimizer): Don't use multiple-value-call-named if the the callee returns a fixed number of values. typed-call-named + move-continuation-result seems to handle the multiple-value-call case just fine. diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 363d6f7..a255ddc 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1801,8 +1801,8 @@ compilation policy") collect (continuation-tn node block arg))) (arg-refs (reference-tn-list cont-tns nil))) (vop allocate-frame node block nil fp nfp) - (cond ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (assert (eq result-tns :unknown)) + (cond ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown) + (eq result-tns :unknown)) (vop* x86::multiple-typed-call-named node block (fp nfp fdefn-tn arg-refs) ((reference-tn-list (ir2-continuation-locs 2cont) t)) commit affcb90ee0d7094ec830181ce8a0cca2863e8d40 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:06:38 2012 +0200 Don't use typed calling convention with wild-args-type. This shouldn't happen normally, but it did happen when I enabled the typed calling convention for all defuns. * compiler/ir1opt.lisp (recognize-known-call): Look at the ftype more closesly. Also ignore known functions. diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 9cb17ab..f00f400 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -953,9 +953,16 @@ (info (ecase cc ((nil) info) ((:typed :typed-no-xep) - (cond ((not info) + (cond ((and (not info) + (let ((ftype (continuation-derived-type + (combination-fun call)))) + (and (function-type-p ftype) + (not (function-type-wild-args + ftype))))) (info function info '%typed-call)) - (t (error "nyi"))))))) + (t + ;;(error "nyi") + info)))))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil))))))) commit 3a9616c76b41ec0287cff3ce23a4860cec28f4b3 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 19:02:27 2012 +0200 Stop freaking out if *check-consistency* is T. Make the checks aware of the typed entry point. diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 18bf155..900559a 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -235,7 +235,8 @@ (check-function-reached ef functional) (unless (or (member functional (optional-dispatch-entry-points ef)) (eq functional (optional-dispatch-more-entry ef)) - (eq functional (optional-dispatch-main-entry ef))) + (eq functional (optional-dispatch-main-entry ef)) + (eq functional (optional-dispatch-typed-entry ef))) (barf ":Optional ~S not an e-p for its OPTIONAL-DISPATCH ~S." functional ef)))) (:top-level @@ -927,7 +928,8 @@ (unless (or (eq (global-conflicts-kind conf) :write) (eq tn pc) (eq tn fp) - (and (external-entry-point-p fun) + (and (or (external-entry-point-p fun) + (typed-entry-point-p fun)) (tn-offset tn)) (member (tn-kind tn) '(:environment :debug-environment)) (member tn vars :key #'leaf-info) commit 636d521a629a8da3442a0b788365596fa67ef6bb Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 18:53:56 2012 +0200 No longer wire arg TNs of typed entry. The XEP no longer calls the typed entry so we don't need wired locations. * compiler/gtn.lisp (assign-typed-lambda-var-tns): Deleted. (assign-normal-lambda-var-tns): Renamed back to assign-lambda-var-tns. (typed-entry-point-type): Take the ftype from the optional-dispatch or the main entry * compiler/ir2tran.lisp (init-typed-entry-point-environment): Now move args from wired locations to locations chosen by GTN. This seems to cause fewer problem during packing. diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 1cc15bf..bce94a5 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -50,14 +50,6 @@ ;;; (defun assign-lambda-var-tns (fun let-p) (declare (type clambda fun)) - (cond ((typed-entry-point-p fun) - (assign-typed-lambda-var-tns fun)) - (t - (assign-normal-lambda-var-tns fun let-p))) - (undefined-value)) - -(defun assign-normal-lambda-var-tns (fun let-p) - (declare (type clambda fun)) (dolist (var (lambda-vars fun)) (when (leaf-refs var) (let* ((type (if (lambda-var-indirect var) @@ -72,16 +64,8 @@ (environment-debug-live-tn temp (lambda-environment fun))))) (setf (tn-leaf res) var) - (setf (leaf-info var) res))))) - -(defun assign-typed-lambda-var-tns (fun) - (declare (type clambda fun)) - (let ((ftype (typed-entry-point-type fun))) - (loop for var in (lambda-vars fun) - for tn in (make-typed-call-tns ftype) - do (when (leaf-refs var) - (setf (tn-leaf tn) var) - (setf (leaf-info var) tn))))) + (setf (leaf-info var) res)))) + (undefined-value)) ;;; Assign-IR2-Environment -- Internal ;;; @@ -233,8 +217,12 @@ :locations (mapcar #'make-normal-tn ptypes)))))) (defun typed-entry-point-type (fun) - (declare (type clambda fun)) - (lambda-type (lambda-entry-function fun))) + (declare (type clambda fun) (values function-type)) + (let* ((opt (lambda-optional-dispatch fun)) + (type1 (optional-dispatch-type opt))) + (typecase type1 + (function-type type1) + (t (lambda-type (optional-dispatch-main-entry opt)))))) (defun return-info-for-typed-entry-point (fun) (declare (type clambda fun)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index a796d1a..363d6f7 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1205,16 +1205,21 @@ compilation policy") (undefined-value)) -;; arguments are wired to specific locations in gtn so we should have -;; to move them here. (defun init-typed-entry-point-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) - (let ((start-label (entry-info-offset (leaf-info fun))) - (code-label (getf (lambda-plist fun) :code-start)) - (env (environment-info (node-environment node)))) + (let* ((start-label (entry-info-offset (leaf-info fun))) + (code-label (getf (lambda-plist fun) :code-start)) + (env (environment-info (node-environment node))) + (ftype (typed-entry-point-type fun)) + (arg-tns (make-typed-call-tns ftype))) (vop typed-entry-point-allocate-frame node block start-label code-label) (vop setup-environment node block start-label) + (loop for var in (lambda-vars fun) + for pass in arg-tns do + (when (leaf-refs var) + (let ((home (leaf-info var))) + (emit-move node block pass home)))) (emit-move node block (make-old-fp-passing-location t) (ir2-environment-old-fp env)))) commit 1ce39124cc2076b5eb64ee0a77979ba14253ca74 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 18:51:24 2012 +0200 Take the type for the fasl file from the optional-dispatch. diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 48f5c96..902f472 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -109,11 +109,9 @@ (defun compute-entry-info (fun info) (declare (type clambda fun) (type entry-info info)) (let* ((bind (lambda-bind fun)) - (internal-fun (functional-entry-function fun)) - (internal-fun (cond ((typed-entry-point-p internal-fun) - (functional-entry-function internal-fun)) - (t internal-fun))) - (tep (typed-entry-point-p fun))) + (tep (typed-entry-point-p fun)) + (internal-fun (cond (tep (lambda-optional-dispatch fun)) + (t (functional-entry-function fun))))) (setf (entry-info-closure-p info) (not (null (environment-closure (lambda-environment fun))))) (setf (entry-info-offset info) (gen-label)) @@ -151,9 +149,6 @@ (case (functional-kind lambda) (:external (let* ((ef (functional-entry-function lambda)) - (ef (cond ((typed-entry-point-p ef) - (functional-entry-function ef)) - (t ef))) (new (make-functional :kind :top-level-xep :info (leaf-info lambda) :name (leaf-name ef) commit dfc1d8a813c922c3c6651af19bf81b7faf4c1dc8 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 18:45:36 2012 +0200 Don't delete the typed entry point as long as a XEP is there. * compiler/envanal.lisp (environment-analyze): Don't delete the typed entry point even if it has no references. * compiler/ir1util.lisp (delete-optional-dispatch): But here delete the typed entry too. diff --git a/src/compiler/envanal.lisp b/src/compiler/envanal.lisp index 4ca29ee..8f96339 100644 --- a/src/compiler/envanal.lisp +++ b/src/compiler/envanal.lisp @@ -57,7 +57,8 @@ (when (null (leaf-refs fun)) (let ((kind (functional-kind fun))) (unless (or (eq kind :top-level) - (and *byte-compiling* (eq kind :optional))) + (and *byte-compiling* (eq kind :optional)) + (typed-entry-point-p fun)) (assert (member kind '(:optional :cleanup :escape))) (setf (functional-kind fun) nil) (delete-functional fun))))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 1082202..bf77e71 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -916,6 +916,8 @@ (frob ep)) (when (optional-dispatch-more-entry leaf) (frob (optional-dispatch-more-entry leaf))) + (when (optional-dispatch-typed-entry leaf) + (frob (optional-dispatch-typed-entry leaf))) (let ((main (optional-dispatch-main-entry leaf))) (when (eq (functional-kind main) :optional) (frob main)))))) commit b4ffef7812b7f1bb378d220fc1e75d0588077c2e Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 23 18:42:08 2012 +0200 Make typed entry point part of optional-dispatch. Previously the typed entry point was a lambda with a marker in the lambda-plist. Now the typed entry point is part of a optional-dispatch struct. The previous approach kinda worked for simple cases, but it was getting awkward when references to the XEP had to be back-patched. The new approach seems to work better; it's nice that both the main entry and the XEP can be reached from the optional-dispatch. * compiler/node.lisp (optional-dispatch): Add new slots. The typedp slot is set during ir1trans and the actual entry point is generated at the same time as the XEP. Doing it a little later lets the types settle a bit better. * compiler/ir1tran.lisp (ir1-convert-lambda): Create a hairy lambda when for the typed calling convention. (ir1-convert-hairy-args): Add new argument typedp and pass it to constructor. * compiler/locall.lisp (generate-typed-entry): New function (make-xep-lambda): Remove the code for the old strategy. (make-external-entry-point): Generate the typed entry point if typed is true. diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index e55b334..ae0c887 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1586,10 +1586,11 @@ (calling-convention (find-declaration 'calling-convention decls 1 0)) (entry-point (find-declaration 'entry-point decls 1 0)) - (res (if (or (find-if #'lambda-var-arg-info vars) keyp) + (typed (eq calling-convention :typed)) + (res (if (or (find-if #'lambda-var-arg-info vars) keyp typed) (ir1-convert-hairy-lambda new-body vars keyp allow-other-keys - aux-vars aux-vals cont) + aux-vars aux-vals cont typed) (ir1-convert-lambda-body new-body vars aux-vars aux-vals t cont)))) (setf (functional-inline-expansion res) form) @@ -1607,7 +1608,7 @@ (eq 'declare (first decl)) (cons 'pcl::method (cadadr decl)))))) (when calling-convention - (setf (getf (lambda-plist res) :calling-convention) + (setf (getf (functional-plist res) :calling-convention) calling-convention)) (when entry-point (setf (getf (lambda-plist res) :entry-point) entry-point)) @@ -1970,7 +1971,7 @@ (cons arg entry-vars) (list* t arg-name entry-vals) (rest vars) t body aux-vars aux-vals cont) - (ir1-convert-hairy-args + (ir1-convert-hairy-args res (cons arg default-vars) (cons arg-name default-vals) @@ -2303,18 +2304,18 @@ nil nil nil vars supplied-p-p body aux-vars aux-vals cont))))))) - ;;; IR1-Convert-Hairy-Lambda -- Internal ;;; ;;; This function deals with the case where we have to make an ;;; Optional-Dispatch to represent a lambda. We cons up the result and call ;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the -;;; min-args and max-args. +;;; min-args and max-args. ;;; -(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont) +(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont + typedp) (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars :allowp allowp - :keyp keyp)) + :keyp keyp :typedp typedp)) (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) (push res (component-new-functions *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals @@ -2331,10 +2332,9 @@ (dolist (ep (optional-dispatch-entry-points res)) (frob ep)) (frob (optional-dispatch-more-entry res)) (frob (optional-dispatch-main-entry res))) - + res)) - (declaim (end-block)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d2582fb..2d3529f 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -145,38 +145,7 @@ (clambda (let* ((nargs (length (lambda-vars fun))) (n-supplied (gensym)) - (temps (loop repeat nargs collect (gensym))) - (fun (ecase (getf (lambda-plist fun) :calling-convention) - ((nil) fun) - (:typed - (let ((fun2 (ir1-convert-lambda - `(lambda ,temps - (declare (entry-point :typed)) - ,@(loop for tmp in temps - for var in (lambda-vars fun) - collect - `(declare (type - ,(type-specifier - (lambda-var-type var)) - ,tmp))) - (%funcall ,fun . ,temps))))) - (setf (lambda-entry-function fun) fun2) - fun2)) - (:typed-no-xep - (return-from make-xep-lambda - `(lambda ,temps - (declare (entry-point :typed) - ,@(loop for tmp in temps - for var in (lambda-vars fun) - collect - `(type ,(type-specifier - (lambda-var-type var)) - ,tmp))) - (the ,(type-specifier - (continuation-asserted-type - (return-result - (lambda-return fun)))) - (%funcall ,fun . ,temps)))))))) + (temps (loop repeat nargs collect (gensym)))) `(lambda (,n-supplied . ,temps) (declare (type index ,n-supplied)) ,(if (policy nil (zerop safety)) @@ -215,6 +184,26 @@ (%argument-count-error ,n-supplied))))))))) +(defun generate-typed-entry (fun) + (declare (type optional-dispatch fun)) + (let* ((main (optional-dispatch-main-entry fun)) + (temps (loop for nil in (lambda-vars main) + collect (gensym))) + (tep (ir1-convert-lambda + `(lambda ,temps + (declare (entry-point :typed)) + ,@(loop for tmp in temps for var in (lambda-vars main) + collect `(declare + (type + ,(type-specifier (lambda-var-type var)) + ,tmp))) + (%funcall ,main . ,temps))))) + (setf (optional-dispatch-typed-entry fun) tep) + (setf (functional-kind tep) :optional) + (setf (leaf-ever-used tep) t) + (setf (lambda-optional-dispatch tep) fun))) + + ;;; Make-External-Entry-Point -- Internal ;;; ;;; Make an external entry point (XEP) for Fun and return it. We convert @@ -237,21 +226,19 @@ (res (ir1-convert-lambda (make-xep-lambda fun)))) (setf (functional-kind res) :external) (setf (leaf-ever-used res) t) - (cond ((functional-entry-function fun) - (let ((ep (functional-entry-function fun))) - (setf (functional-entry-function ep) fun) - (setf (functional-entry-function fun) ep) - (setf (functional-entry-function res) ep))) - (t - (setf (functional-entry-function res) fun) - (setf (functional-entry-function fun) res))) + (setf (functional-entry-function res) fun) + (setf (functional-entry-function fun) res) (setf (component-reanalyze *current-component*) t) (setf (component-reoptimize *current-component*) t) (etypecase fun (clambda (local-call-analyze-1 fun)) (optional-dispatch + (when (optional-dispatch-typedp fun) + (generate-typed-entry fun)) (dolist (ep (optional-dispatch-entry-points fun)) (local-call-analyze-1 ep)) + (when (optional-dispatch-typed-entry fun) + (local-call-analyze-1 (optional-dispatch-typed-entry fun))) (when (optional-dispatch-more-entry fun) (local-call-analyze-1 (optional-dispatch-more-entry fun))))) res))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 851d9bf..ece4061 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -1037,7 +1037,11 @@ ;; including keywords as fixed arguments. The format of the arguments must ;; be determined by examining the arglist. This may be used by callers that ;; supply at least Max-Args arguments and know what they are doing. - (main-entry nil :type (or clambda null))) + (main-entry nil :type (or clambda null)) + ;; + ;; True if a typed entry point should be generated. + (typedp nil :type boolean :read-only t) + (typed-entry nil :type (or clambda null))) (defprinter optional-dispatch commit 8a35f2256800afd1f0962c33fed7f64303e6c3be Merge: 8a9d1d8 6b3aba6 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Jun 23 08:24:44 2012 -0700 Merge branch 'tcall-convention' of https://github.com/ellerh/cmucl into eller-typed-call commit b974e915a0399bb432cc21cd4d1723a1423e00bd Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 22 12:30:47 2012 +0200 Don't need fop-fset for typed entry points. diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index c3b2ed0..f7badbe 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -660,7 +660,9 @@ ;; flet/labels functions. We don't ;; need them stored because we can't ;; really do anything with them. - (not (member (car name) '(flet labels) :test 'eq) )))) + (not (member (car name) + '(flet labels :typed-entry-point) + :test 'eq) )))) (dump-object name file) (dump-push handle file) (dump-fop 'lisp::fop-fset file)) commit e48ee801750f31adb490bb8118a67bd3f37bf85b Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 22 12:29:18 2012 +0200 Disable local inline expansion into typed entry points. * compiler/locall.lisp (maybe-expand-local-inline): Treat typed entry points like external entry points. diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d2e8d3e..d2582fb 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -362,7 +362,9 @@ ;;; (defun maybe-expand-local-inline (fun ref call) (if (and (policy call (>= speed space) (>= speed cspeed)) - (not (eq (functional-kind (node-home-lambda call)) :external)) + (not (let ((home (node-home-lambda call))) + (or (external-entry-point-p home) + (typed-entry-point-p home)))) (not *converting-for-interpreter*) (inline-expansion-ok call)) (with-ir1-environment call commit efd05b70ebbe8f38541f295901ce46038b072a38 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 22 12:13:22 2012 +0200 Handle unused arguments. * compiler/ir2tran.lisp (ir2-convert-local-typed-call): Skip over unsed args. diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index fd0855e..a796d1a 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -914,13 +914,16 @@ compilation policy") nfp number-stack-frame-size) (make-typed-call-tns ftype) (declare (ignore number-stack-frame-size)) - (let ((cont-tns (loop for arg in args - collect (continuation-tn node block arg)))) + (collect ((actuals) (arg-locs)) + (loop for arg in args for loc in arg-tns do + (when arg + (actuals (continuation-tn node block arg)) + (arg-locs loc))) (vop allocate-frame node block nil fp nfp) (vop* typed-call-local node block - (fp nfp (reference-tn-list cont-tns nil)) + (fp nfp (reference-tn-list (actuals) nil)) ((reference-tn-list result-tns t)) - arg-tns stack-frame-size start) + (arg-locs) stack-frame-size start) (move-continuation-result node block result-tns cont))))) ;;; IR2-Convert-Local-Call -- Internal commit e81e7591484df73c3515cfe21495059b4586b364 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 22 12:09:49 2012 +0200 In %defun, closures and known functions are problematic. For now, disable the typed convention for them. diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index f4ce61d..e55b334 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -3994,7 +3994,9 @@ (decls (nth-value 1 (system:parse-body (cddr lambda) *lexical-environment* t))) (convention (find-declaration 'calling-convention decls 1 0))) - (cond (convention + (cond ((and convention + (not (info function info name)) + (and (null (lexenv-variables *lexical-environment*)))) (setf (info function calling-convention name) convention)) (t (clear-info function calling-convention name))) @@ -4002,7 +4004,7 @@ ;; If not in a simple environment or :notinline, then discard any forward ;; references to this function. (unless expansion (remhash name *free-functions*)) - + (let* ((var (get-defined-function name)) (save-expansion (and (member (defined-function-inlinep var) '(:inline :maybe-inline)) @@ -4014,7 +4016,7 @@ ;; obsolete. (when (eq (leaf-where-from var) :defined) (setf (leaf-type var) (specifier-type 'function))) - + (let ((fun (ir1-convert-lambda-for-defun lambda var expansion #'ir1-convert-lambda 'defun))) commit fc5f13bfaa060e628f69b0e2c13e07b05140403b Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 22 12:07:35 2012 +0200 Be more careful when searching the typed entry point of functions. The function might be a closure and we can't access the code object for those. diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 6f8063f..61725e6 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -288,11 +288,16 @@ (equal (cadr fname) name)) (return ep))))) +(defun find-typed-entry-point-for-function (xep name) + (declare (type function xep)) + (when (= (kernel:get-type xep) vm:function-header-type) + (let ((code (function-code-header xep))) + (find-typed-entry-point-in-code code name)))) + (defun find-typed-entry-point-for-fdefn (fdefn) (let ((xep (fdefn-function fdefn))) - (when xep - (let ((code (function-code-header xep))) - (find-typed-entry-point-in-code code (fdefn-name fdefn)))))) + (when (functionp xep) + (find-typed-entry-point-for-function xep (fdefn-name fdefn))))) ;; find-typed-entry-point is called at load-time and returns the ;; fdefn that should be called. @@ -463,9 +468,8 @@ (defun check-function-redefinition (name new-fun) (multiple-value-bind (linkage foundp) (ext:info function linkage name) (when foundp - (let* ((new-code (function-code-header new-fun)) - (new-tep (find-typed-entry-point-in-code new-code name)) - (new-type (if new-tep + (let* ((new-tep (find-typed-entry-point-for-function new-fun name)) + (new-type (if new-tep (extract-function-type new-tep) (specifier-type '(function * *))))) (dolist (cs (listify (linkage-callsites linkage))) commit 8acb0481d5312d799fb0febf43c19e1be2ae5b58 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Wed Jun 20 11:00:39 2012 +0200 In the cross-build Make-rule, build PCL too. diff --git a/Makefile b/Makefile index f69a09f..1fe4a0a 100644 --- a/Makefile +++ b/Makefile @@ -350,14 +350,18 @@ cross-build: bin/create-target.sh xtarget cp src/tools/cross-scripts/cross-x86-x86.lisp xtarget/cross.lisp ifeq ($(XBOOTFILE),) - bin/cross-build-world.sh -crl \ + bin/cross-build-world.sh -cr \ xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) else - bin/cross-build-world.sh -crl \ + bin/cross-build-world.sh -cr \ -B $(XBOOTFILE) xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) endif bin/rebuild-lisp.sh xtarget bin/load-world.sh -p xtarget "newlisp" + bin/create-target.sh xstage2 + bin/build-world.sh xstage2 xtarget/lisp/lisp + bin/rebuild-lisp.sh xstage2 + bin/load-world.sh xstage2 "newlisp2" sanity: @if [ `echo $(TOPDIR) | egrep -c '^/'` -ne 1 ]; then \ commit b15f6293c59f4ec7bd80fe2c628e29f4afae4590 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Wed Jun 20 10:59:48 2012 +0200 Load files into cross-compiler. diff --git a/src/bootfiles/20c/tccxboot.lisp b/src/bootfiles/20c/tccxboot.lisp index e149843..d54fc23 100644 --- a/src/bootfiles/20c/tccxboot.lisp +++ b/src/bootfiles/20c/tccxboot.lisp @@ -3,7 +3,7 @@ (c::define-info-type function c::calling-convention symbol nil) (c::define-info-type function lisp::linkage lisp::linkage nil) -(delete-file (compile-file "target:compiler/knownfun")) -(delete-file (compile-file "target:code/load")) +(delete-file (compile-file "target:compiler/knownfun" :load t)) +(delete-file (compile-file "target:code/load" :load t)) commit 7bc1550b6965f3399f66d5d1c8eb30c3b242b914 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Wed Jun 20 10:57:03 2012 +0200 Some small improvements in the linker code. * code/fdenition.lisp (find-typed-entry-point): Enable sharing of callsite objects if the types match. (generate-adapter-function): Bind *derive-function-types* for stricter type checks. (check-function-redefinition): Handle case where the new function doesn't have an entry point. Also use (:adapter <foo>) as name for adapter functions. (patch-fdefn): Take name as optional argument. diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 89d1b4e..6f8063f 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -325,10 +325,10 @@ (cond (foundp info) (t (setf (ext:info function linkage name) (make-linkage))))))) - (cond ((and nil (dolist (cs (listify (linkage-callsites linkage))) + (cond ((dolist (cs (listify (linkage-callsites linkage))) (let* ((ep-type (callsite-type cs))) (when (function-types-compatible-p cs-type ep-type) - (return (callsite-fdefn cs))))))) + (return (callsite-fdefn cs)))))) ((let ((fdefn (fdefinition-object name nil))) (when fdefn (let ((fun (find-typed-entry-point-for-fdefn fdefn))) @@ -388,6 +388,7 @@ (declare (type function-type ftype)) (let* ((atypes (function-type-required ftype)) (tmps (loop for nil in atypes collect (gensym))) + (*derive-function-types* nil) (fun (compile nil `(lambda ,tmps @@ -464,7 +465,9 @@ (when foundp (let* ((new-code (function-code-header new-fun)) (new-tep (find-typed-entry-point-in-code new-code name)) - (new-type (extract-function-type new-tep))) + (new-type (if new-tep + (extract-function-type new-tep) + (specifier-type '(function * *))))) (dolist (cs (listify (linkage-callsites linkage))) (let ((cs-type (callsite-type cs)) (fdefn (callsite-fdefn cs))) @@ -473,16 +476,16 @@ ((dolist (fun (listify (linkage-adapters linkage))) (let ((ep-type (kernel:extract-function-type fun))) (when (function-types-compatible-p cs-type ep-type) - (patch-fdefn fdefn fun) + (patch-fdefn fdefn fun `(:adapter ,name)) (return t))))) (t (let ((fun (generate-adapter-function cs-type name))) (push-unlistified fun (linkage-adapters linkage)) - (patch-fdefn fdefn fun)))))))))) + (patch-fdefn fdefn fun `(:adapter ,name))))))))))) -(defun patch-fdefn (fdefn new-fun) +(defun patch-fdefn (fdefn new-fun &optional name) (setf (kernel:fdefn-function fdefn) new-fun) - (let ((name (kernel:%function-name new-fun))) + (let ((name (or name (kernel:%function-name new-fun)))) (kernel:%set-fdefn-name fdefn name)) fdefn) commit 376e5ea8fccf76f1ecaab4ebb2c0e0aa80bd1809 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Wed Jun 20 10:53:06 2012 +0200 Add support for wild/unknown return types. * compiler/x86/call.lisp (make-typed-call-tns): If the number of return values is not fixed return the symbol :unknown instead of a list of TNs. * compiler/gtn.lisp (return-info-for-typed-entry-point): For :unknown number of return values use the standard return convention. * compiler/ir2tran.lisp ([ir2convert] %typed-call): Generate different code for :unknown number of return values. * compiler/x86/call.lisp ([vop] typed-call-named): Take an additional info argument NRESULTS that indicates that we should use standard return convention. * compiler/x86/call.lisp ([vop] multiple-typed-call-named): New vop. diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index fee6afa..1cc15bf 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -240,10 +240,14 @@ (declare (type clambda fun)) (let* ((ftype (typed-entry-point-type fun)) (tns (nth-value 1 (make-typed-call-tns ftype)))) - (make-return-info :kind :fixed - :count (length tns) - :types (mapcar #'tn-primitive-type tns) - :locations tns))) + (etypecase tns + ((eql :unknown) + (return-info-for-set (lambda-tail-set fun))) + (list + (make-return-info :kind :fixed + :count (length tns) + :types (mapcar #'tn-primitive-type tns) + :locations tns))))) ;;; Assign-Return-Locations -- Internal ;;; diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 9328298..fd0855e 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1780,22 +1780,38 @@ compilation policy") (defoptimizer (%typed-call ir2-convert) ((&rest args) node block) (let* ((fun (combination-fun node)) (ftype (continuation-derived-type fun)) - (cont (node-cont node))) + (cont (node-cont node)) + (2cont (continuation-info cont))) (check-type ftype function-type) (multiple-value-bind (arg-tns result-tns fp stack-frame-size nfp number-stack-frame-size) (make-typed-call-tns ftype) (declare (ignore number-stack-frame-size)) - (let ((fdefn-tn (typed-entry-point-continuation-tn fun ftype)) - (cont-tns (loop for arg in args - collect (continuation-tn node block arg)))) + (let* ((fdefn-tn (typed-entry-point-continuation-tn fun ftype)) + (cont-tns (loop for arg in args + collect (continuation-tn node block arg))) + (arg-refs (reference-tn-list cont-tns nil))) (vop allocate-frame node block nil fp nfp) - (vop* typed-call-named node block - (fp nfp fdefn-tn (reference-tn-list cont-tns nil)) - ((reference-tn-list result-tns t)) - arg-tns stack-frame-size) - (move-continuation-result node block result-tns cont))))) + (cond ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) + (assert (eq result-tns :unknown)) + (vop* x86::multiple-typed-call-named node block + (fp nfp fdefn-tn arg-refs) + ((reference-tn-list (ir2-continuation-locs 2cont) t)) + arg-tns stack-frame-size)) + ((eq result-tns :unknown) + (let ((locs (standard-result-tns cont))) + (vop* typed-call-named node block + (fp nfp fdefn-tn arg-refs) + ((reference-tn-list locs t)) + arg-tns stack-frame-size (length locs)) + (move-continuation-result node block locs cont))) + (t + (vop* typed-call-named node block + (fp nfp fdefn-tn arg-refs) + ((reference-tn-list result-tns t)) + arg-tns stack-frame-size nil) + (move-continuation-result node block result-tns cont))))))) ;;; IR2-Convert -- Interface diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 90d9259..cad0b46 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -234,16 +234,19 @@ '(double-reg descriptor-reg))) tn))) (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) - (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) - (returns (function-type-returns ftype)) - (rtypes (typecase returns - (values-type (values-type-required returns)) - (t (list returns))))) + (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0))) (values - (loop for type in (function-type-required ftype) - collect (arg-tn type arg-state)) - (loop for type in rtypes - collect (ret-tn type ret-state)) + (multiple-value-bind (min max) (function-type-nargs ftype) + (assert (and min max (= min max)) () + "Only fixed number of arguments supported (currently)") + (loop for type in (function-type-required ftype) + collect (arg-tn type arg-state))) + (multiple-value-bind (types count) + (values-types (function-type-returns ftype)) + (cond ((eq count :unknown) :unknown) + (t + (loop for type in types + collect (ret-tn type ret-state))))) (x86-make-stack-pointer-tn) (max (getf arg-state :frame-size) (getf ret-state :frame-size)) @@ -1159,8 +1162,8 @@ (:save-p t) (:move-args :local-call) (:vop-var vop) - (:info arg-locs real-frame-size) - (:ignore new-nfp args arg-locs results) + (:info arg-locs real-frame-size nresults) + (:ignore new-nfp args arg-locs) (:temporary (:sc descriptor-reg :offset eax-offset) eax) (:generator 30 @@ -1186,8 +1189,52 @@ (inst call (make-ea :dword :base eax :disp (- (* fdefn-raw-addr-slot word-bytes) other-pointer-type))) + (when nresults + (default-unknown-values vop results nresults)) )) + +(define-vop (multiple-typed-call-named unknown-values-receiver) + (:args (new-fp) + (new-nfp) + (fdefn :scs (descriptor-reg control-stack) + :target eax) + (args :more t :scs (descriptor-reg))) + (:temporary (:sc descriptor-reg :offset eax-offset) + eax) + (:save-p t) + (:move-args :local-call) + (:info arg-locs real-frame-size) + (:ignore new-nfp args arg-locs) + (:vop-var vop) + (:generator 30 + ;; FIXME: allocate the real frame size here. We had to emit + ;; ALLOCATE-FRAME before this vop so that we can use the + ;; (:move-args :local-call) option here. Without the + ;; ALLOCATE-FRAME vop we get a failed assertion. + (inst lea esp-tn (make-ea :dword :base new-fp + :disp (- (* real-frame-size word-bytes)))) + + ;; Move fdefn to eax before switching frames. + (move eax fdefn) + + ;; Write old frame pointer (epb) into new frame. + (storew ebp-tn new-fp (- (1+ ocfp-save-offset))) + + ;; Switch to new frame. + (move ebp-tn new-fp) + + (note-this-location vop :call-site) + + ;; Load address out of fdefn and call it. + (inst call (make-ea :dword :base eax + :disp (- (* fdefn-raw-addr-slot word-bytes) + other-pointer-type))) + + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count) + (trace-table-entry trace-table-normal))) + ;;;; Unknown values return: commit 6b3aba66b6756339a54ca4bdcea43d6b0db807d1 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sun Jun 17 21:04:47 2012 +0200 Pass XBOOTFILE as argument to cross-build-world.sh diff --git a/Makefile b/Makefile index 98024b4..f69a09f 100644 --- a/Makefile +++ b/Makefile @@ -349,7 +349,13 @@ cross-build: bin/create-target.sh xcross bin/create-target.sh xtarget cp src/tools/cross-scripts/cross-x86-x86.lisp xtarget/cross.lisp - bin/cross-build-world.sh xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) +ifeq ($(XBOOTFILE),) + bin/cross-build-world.sh -crl \ + xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) +else + bin/cross-build-world.sh -crl \ + -B $(XBOOTFILE) xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) +endif bin/rebuild-lisp.sh xtarget bin/load-world.sh -p xtarget "newlisp" commit 60a63d8efa0d7f0129b1a5466d45e84daff84f09 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sun Jun 17 21:02:17 2012 +0200 Use compile-file instead of comf in boot file. diff --git a/src/bootfiles/20c/tccxboot.lisp b/src/bootfiles/20c/tccxboot.lisp index fb1eb81..e149843 100644 --- a/src/bootfiles/20c/tccxboot.lisp +++ b/src/bootfiles/20c/tccxboot.lisp @@ -3,4 +3,7 @@ (c::define-info-type function c::calling-convention symbol nil) (c::define-info-type function lisp::linkage lisp::linkage nil) -(comf "target:code/load" :load t) +(delete-file (compile-file "target:compiler/knownfun")) +(delete-file (compile-file "target:code/load")) + + commit dadf9066b180da5b52341651f63353b25ac85fbb Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sun Jun 17 21:01:17 2012 +0200 Use :typed-no-xep convention when creating for adapters. diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index db55172..89d1b4e 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -290,8 +290,9 @@ (defun find-typed-entry-point-for-fdefn (fdefn) (let ((xep (fdefn-function fdefn))) - (let ((code (function-code-header xep))) - (find-typed-entry-point-in-code code (fdefn-name fdefn))))) + (when xep + (let ((code (function-code-header xep))) + (find-typed-entry-point-in-code code (fdefn-name fdefn)))))) ;; find-typed-entry-point is called at load-time and returns the ;; fdefn that should be called. @@ -370,6 +371,12 @@ (declare (ignore args)) (error "Linking callsite to typed-entry-point failed")) +(defun validate-adapter-type (fun ftype) + (let ((etype (extract-function-type fun))) + (unless (function-types-compatible-p ftype etype t) + (break))) + fun) + ;; Generate an adapter function that changes the representation of the ;; arguments (specified with FTYPE) and forwards the call to NAME. ;; The adapter has also a typed entry point. It should also check @@ -378,31 +385,22 @@ ;; In practice, the compiler infered type may not match exactly FTYPE, ;; even if we add lotso declarations. This is annyoingly brittle. (defun generate-adapter-function (ftype name) - (let* ((atypes (kernel:function-type-required ftype)) + (declare (type function-type ftype)) + (let* ((atypes (function-type-required ftype)) (tmps (loop for nil in atypes collect (gensym))) - (fname `(:typed-entry-point - :boxing-adapter ,(make-symbol (string name)))) - (ftypespec (kernel:type-specifier ftype))) - (proclaim `(ftype ,ftypespec ,fname)) - (compile fname - `(lambda ,tmps - (declare - ,@(loop for tmp in tmps - for type in atypes - collect `(type ,(kernel:type-specifier type) ,tmp))) - (the ,(kernel:type-specifier - (kernel:function-type-returns ftype)) - (funcall (function ,name) . ,tmps)))) - (let ((fun (fdefinition fname))) - (unless (eq name 'linkage-error) - (fix-ftype fun ftype)) - fun))) - -(defun fix-ftype (fun ftype) - (let ((etype (kernel:extract-function-type fun))) - (unless (function-types-compatible-p ftype etype t) - (break))) - fun) + (fun (compile + nil + `(lambda ,tmps + (declare + (c::calling-convention :typed-no-xep) + ,@(loop for tmp in tmps + for type in atypes + collect `(type ,(kernel:type-specifier type) ,tmp))) + (the ,(kernel:type-specifier + (kernel:function-type-returns ftype)) + (funcall (function ,name) . ,tmps)))))) + (validate-adapter-type fun ftype) + fun)) ;; This is our rule to decide when a type at a callsite matches the ;; type of the entry point. commit 19eb5e3a6e0c3146bae8787e469610c9f2778a14 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sun Jun 17 20:02:47 2012 +0200 Call :typed-no-xep functions like the :typed convention. This probably doesn't come up in practise but may be useful for testing. diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 1ded755..9cb17ab 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -952,9 +952,10 @@ (cc (info function calling-convention name)) (info (ecase cc ((nil) info) - (:typed (cond ((not info) - (info function info '%typed-call)) - (t (error "nyi"))))))) + ((:typed :typed-no-xep) + (cond ((not info) + (info function info '%typed-call)) + (t (error "nyi"))))))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil))))))) commit c5794cf2d324ee899984b67911e37df4a8c6b66d Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sun Jun 17 19:59:12 2012 +0200 Handle new cases for the :typed-no-xep. Some lambdas are now both external-entry-point-p and typed-entry-point-p and we need to handle those cases a bit more carefully. diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 8a8c18f..48f5c96 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -38,7 +38,7 @@ (setf (leaf-info fun) (make-entry-info))))) (compute-entry-info fun info) (push info (ir2-component-entries 2comp)) - (when (getf (lambda-plist fun) :entry-point) + (when (typed-entry-point-p fun) (setf (getf (lambda-plist fun) :code-start) (gen-label))))))) (select-component-format component) diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 39d9b17..fee6afa 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -50,11 +50,10 @@ ;;; (defun assign-lambda-var-tns (fun let-p) (declare (type clambda fun)) - (ecase (getf (lambda-plist fun) :entry-point) - ((nil) - (assign-normal-lambda-var-tns fun let-p)) - (:typed - (assign-typed-lambda-var-tns fun))) + (cond ((typed-entry-point-p fun) + (assign-typed-lambda-var-tns fun)) + (t + (assign-normal-lambda-var-tns fun let-p))) (undefined-value)) (defun assign-normal-lambda-var-tns (fun let-p) @@ -77,7 +76,7 @@ (defun assign-typed-lambda-var-tns (fun) (declare (type clambda fun)) - (let ((ftype (lambda-type fun))) + (let ((ftype (typed-entry-point-type fun))) (loop for var in (lambda-vars fun) for tn in (make-typed-call-tns ftype) do (when (leaf-refs var) @@ -206,18 +205,16 @@ ;;; (defun choose-return-locations (fun) (declare (type clambda fun)) - (ecase (getf (lambda-plist fun) :entry-point) - ((nil) - (let* ((tails (lambda-tail-set fun)) - (ep (find-if (lambda (fun) - (getf (lambda-plist fun) :entry-point)) - (tail-set-functions tails)))) - (cond (ep - (return-info-for-typed-convention ep)) - (t - (return-info-for-set tails))))) - (:typed - (return-info-for-typed-convention fun)))) + (cond ((typed-entry-point-p fun) + (return-info-for-typed-entry-point fun)) + (t + (let* ((tails (lambda-tail-set fun)) + (ep (find-if #'typed-entry-point-p + (tail-set-functions tails)))) + (cond (ep + (return-info-for-typed-entry-point ep)) + (t + (return-info-for-set tails))))))) (defun return-info-for-set (tails) (declare (type tail-set tails)) @@ -235,9 +232,13 @@ :types ptypes :locations (mapcar #'make-normal-tn ptypes)))))) -(defun return-info-for-typed-convention (fun) +(defun typed-entry-point-type (fun) (declare (type clambda fun)) - (let* ((ftype (lambda-type fun)) + (lambda-type (lambda-entry-function fun))) + +(defun return-info-for-typed-entry-point (fun) + (declare (type clambda fun)) + (let* ((ftype (typed-entry-point-type fun)) (tns (nth-value 1 (make-typed-call-tns ftype)))) (make-return-info :kind :fixed :count (length tns) @@ -260,7 +261,8 @@ (return (lambda-return fun))) (when (and return (not (eq (return-info-kind returns) :unknown)) - (external-entry-point-p fun)) + (external-entry-point-p fun) + (not (typed-entry-point-p fun))) (do-uses (use (return-result return)) (setf (node-tail-p use) nil)))) (undefined-value)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index d1aa8b5..9328298 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1232,13 +1232,14 @@ compilation policy") (assert (member (functional-kind fun) '(nil :external :optional :top-level :cleanup))) - (when (external-entry-point-p fun) + (when (and (external-entry-point-p fun) + (not (typed-entry-point-p fun))) (init-xep-environment node block fun) (when *collect-dynamic-statistics* (vop count-me node block *dynamic-counts-tn* (block-number (ir2-block-block block))))) - (when (getf (lambda-plist fun) :entry-point) + (when (typed-entry-point-p fun) (init-typed-entry-point-environment node block fun)) (emit-move node block (ir2-environment-return-pc-pass env) commit d6c4b0fb87a0b480ddd12108d7800724c5fcfc34 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sun Jun 17 19:54:35 2012 +0200 Don't create a XEP for the :typed-no-xep calling convention. The :typed-no-xep convention is intended for adapter functions where the general XEP would not be used. Naming is a bit confusing now as those typed entry points actually have the lambda-kind :external so external-entry-point-p and typed-entry-point-p both return true. diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 6882f92..d2e8d3e 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -161,7 +161,22 @@ ,tmp))) (%funcall ,fun . ,temps))))) (setf (lambda-entry-function fun) fun2) - fun2))))) + fun2)) + (:typed-no-xep + (return-from make-xep-lambda + `(lambda ,temps + (declare (entry-point :typed) + ,@(loop for tmp in temps + for var in (lambda-vars fun) + collect + `(type ,(type-specifier + (lambda-var-type var)) + ,tmp))) + (the ,(type-specifier + (continuation-asserted-type + (return-result + (lambda-return fun)))) + (%funcall ,fun . ,temps)))))))) `(lambda (,n-supplied . ,temps) (declare (type index ,n-supplied)) ,(if (policy nil (zerop safety)) commit 617698bba6f63bed808d859f559bd73c503a7837 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sun Jun 17 09:39:25 2012 +0200 Add unsafe setter %set-fdefn-name. That's useful for debugging. diff --git a/src/bootfiles/20c/tccxboot.lisp b/src/bootfiles/20c/tccxboot.lisp index f9e50e2..fb1eb81 100644 --- a/src/bootfiles/20c/tccxboot.lisp +++ b/src/bootfiles/20c/tccxboot.lisp @@ -3,5 +3,4 @@ (c::define-info-type function c::calling-convention symbol nil) (c::define-info-type function lisp::linkage lisp::linkage nil) -(comf "target:code/fdefinition" :load t) (comf "target:code/load" :load t) diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 060ad89..865b6e1 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2261,8 +2261,8 @@ "VALUES-TYPE-REQUIRED" "VALUES-TYPE-REST" "VALUES-TYPE-UNION" "VALUES-TYPES" "VALUES-TYPES-INTERSECT" "VOID" "WITH-CIRCULARITY-DETECTION" "WRONG-NUMBER-OF-INDICES-ERROR" - "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUNCTION" - "FDEFN-OR-LOSE" + "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "%SET-FDEFN-NAME" + "FDEFN-FUNCTION" "FDEFN-OR-LOSE" "FDEFN-MAKUNBOUND" "%COERCE-TO-FUNCTION" "FUNCTION-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST" "INFINITE-ERROR-PROTECT" diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 3555372..db55172 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -482,17 +482,10 @@ (push-unlistified fun (linkage-adapters linkage)) (patch-fdefn fdefn fun)))))))))) -;; This lets us set the name in fdefn objects. We use that for -;; debugging. -#-bootstrap -(eval-when (:compile-toplevel) - (c:defknown set-fdefn-name (kernel:fdefn t) t) - (c:def-setter set-fdefn-name vm:fdefn-name-slot vm:other-pointer-type)) - (defun patch-fdefn (fdefn new-fun) (setf (kernel:fdefn-function fdefn) new-fun) (let ((name (kernel:%function-name new-fun))) - (set-fdefn-name fdefn name)) + (kernel:%set-fdefn-name fdefn name)) fdefn) (pushnew 'check-function-redefinition ext:*setf-fdefinition-hook*) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index da04b4f..5c912a6 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -306,7 +306,7 @@ (define-primitive-object (fdefn :type fdefn :lowtag other-pointer-type :header fdefn-type) - (name :ref-trans fdefn-name) + (name :ref-trans fdefn-name :set-trans %set-fdefn-name :set-known (unsafe)) (function :type (or function null) :ref-trans fdefn-function) (raw-addr :c-type #-alpha "char *" #+alpha "u32")) commit 186d3c0814b3e0db9662f84b3fefb1b049bfe790 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:56:30 2012 +0200 In comf, enter the debugger before Error Aborts. diff --git a/src/tools/setup.lisp b/src/tools/setup.lisp index 2e0cf1c..9277b55 100644 --- a/src/tools/setup.lisp +++ b/src/tools/setup.lisp @@ -282,6 +282,7 @@ (error (condition) (declare (ignore condition)) (format t "Error in backtrace!~%"))) + (break condition) (format t "Error abort.~%") (return-from comf))))) (if assem commit d367449f21e17828dbc48f6da1ec7dfc88a9881e Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:52:11 2012 +0200 Add bootfiles/20c/tccxboot.lisp and using for the build. In tools/cross-scripts/cross-x86-x86.lisp remove the code that imports symbols from OLD-X86 into X86. We don't want genesis to dump the OLD-X86 package. diff --git a/Makefile b/Makefile index 808ba2a..98024b4 100644 --- a/Makefile +++ b/Makefile @@ -7,6 +7,7 @@ BUILDDIR := $(TOPDIR)/build BOOTCMUCL := cmucl XHOST := x86 XTARGET := x86 +XBOOTFILE := BOOTFILE := help: @@ -33,14 +34,15 @@ BUILDDIR build directory ($(BUILDDIR))\n\ BOOTCMUCL compiler used for bootstrap ($(BOOTCMUCL))\n\ XHOST host system ($(XHOST))\n\ XTARGET target system ($(XTARGET))\n\ -BOOTFILE file for bootstrap hacks (default: none)\ +XBOOTFILE file to execute before building cross-compiler (default: none)\n\ +BOOTFILE file to initialize compiler (default: none)\ " help-other: @echo -e "\ -xcompile-world -- cross-compile library \n\ +xcompile-world -- cross-compile core components (no compiler) \n\ xcompile-compiler -- cross-compile compiler \n\ -xdump-world -- cold-load library and cross-dump (genesis)\n\ +xdump-world -- genesis (emulate loading then dump the emulated heap)\n\ clean-world -- remove the build/world directory\n\ sanity-clean -- remove fasl files in source directory\n\ run-xcompiler -- open a REPL with the cross-compiler\ @@ -93,6 +95,12 @@ LOAD_BOOTFILE=' \ (load bootfile))) \ ' +LOAD_XBOOTFILE=' \ +(let ((bootfile "$(XBOOTFILE)")) \ + (unless (equal bootfile "") \ + (load bootfile))) \ +' + SET_TARGET_SEARCH_LIST=(setf (ext:search-list "target:") (list $(1) "src/")) XSETENV=' \ @@ -184,6 +192,7 @@ $(BUILDDIR)/xcompiler/cross-%.core: -eval '(load "target:tools/setup" :if-source-newer :load-source)' \ -eval '(comf "target:tools/setup" :load t)' \ -eval '(setq *gc-verbose* nil *interactive* nil)' \ +-eval $(LOAD_XBOOTFILE) \ -eval '(load "$(XCOMPILERDIR)/cross.lisp")' \ -eval '(remf ext::*herald-items* :python)' \ -eval '(ext:save-lisp "$@" :purify nil)' \ diff --git a/src/bootfiles/20c/tccxboot.lisp b/src/bootfiles/20c/tccxboot.lisp new file mode 100644 index 0000000..f9e50e2 --- /dev/null +++ b/src/bootfiles/20c/tccxboot.lisp @@ -0,0 +1,7 @@ + +;; boot file for cross-compiler to add typed calling convention. + +(c::define-info-type function c::calling-convention symbol nil) +(c::define-info-type function lisp::linkage lisp::linkage nil) +(comf "target:code/fdefinition" :load t) +(comf "target:code/load" :load t) diff --git a/src/tools/cross-scripts/cross-x86-x86.lisp b/src/tools/cross-scripts/cross-x86-x86.lisp index 87c2dad..afe7dfa 100644 --- a/src/tools/cross-scripts/cross-x86-x86.lisp +++ b/src/tools/cross-scripts/cross-x86-x86.lisp @@ -37,20 +37,14 @@ (pushnew :bootstrap *features*) (pushnew :building-cross-compiler *features*) -;; Make fixup-code-object and sanctify-for-execution in the VM package -;; be the same as the original. Needed to get rid of a compiler error -;; in generic/core.lisp. (This halts cross-compilations if the -;; compiling lisp uses the -batch flag. -(import 'old-vm::fixup-code-object "VM") -(import 'old-vm::sanctify-for-execution "VM") -(export 'vm::fixup-code-object "VM") -(export 'vm::sanctify-for-execution "VM") - -;; -(unless (find "CALLING-CONVENTION" - (c::class-info-types (gethash "FUNCTION" c::*info-classes*)) - :key #'c::type-info-name :test #'equal) - (c::define-info-type function c::calling-convention symbol nil)) +;;;; Make fixup-code-object and sanctify-for-execution in the VM package +;;;; be the same as the original. Needed to get rid of a compiler error +;;;; in generic/core.lisp. (This halts cross-compilations if the +;;;; compiling lisp uses the -batch flag. +;;(import 'old-vm::fixup-code-object "VM") +;;(import 'old-vm::sanctify-for-execution "VM") +;;(export 'vm::fixup-code-object "VM") +;;(export 'vm::sanctify-for-execution "VM") (comf "target:code/exports") @@ -224,3 +218,4 @@ (setf (gethash 'old-vm::any-reg ht) (gethash 'vm::any-reg ht))) +(delete-package "OLD-X86") commit 340d7957960208ecfb59f69b8f76a15792a842d9 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:50:25 2012 +0200 Add runtime support for linking. For now that code lives in code/fdefinition.lisp. diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index b7a4033..3555372 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -255,3 +255,244 @@ (fdefn-makunbound fdefn))) (kernel:undefine-function-name name) name) + + + +(defstruct callsite + (type (ext:required-argument) :type kernel:function-type :read-only t) + (fdefn (ext:required-argument) :type kernel:fdefn :read-only t)) + +(defstruct linkage + (callsites nil :type (or callsite list)) + (adapters nil :type (or function list))) + +(defun listify (x) + (if (listp x) x (list x))) + +(defmacro push-unlistified (new-value (reader object)) + `(let ((new-value ,new-value) (object ,object)) + (let ((old-value (,reader ,object))) + (setf (,reader object) + (typecase old-value + (null new-value) + (cons (cons new-value old-value)) + (t (list new-value old-value))))))) + +(defun find-typed-entry-point-in-code (code name) + (loop for ep = (%code-entry-points code) then (%function-next ep) + while ep do + (let ((fname (%function-name ep))) + (when (and (consp fname) + (eq (car fname) :typed-entry-point) + (consp (cdr fname)) + (equal (cadr fname) name)) + (return ep))))) + +(defun find-typed-entry-point-for-fdefn (fdefn) + (let ((xep (fdefn-function fdefn))) + (let ((code (function-code-header xep))) + (find-typed-entry-point-in-code code (fdefn-name fdefn))))) + +;; find-typed-entry-point is called at load-time and returns the +;; fdefn that should be called. +;; +;; 1. We go through the list of existing callsites to see if we +;; already have one with the same type and reuse it if possible. +;; +;; 2. We look at the current definition. If the types match, we +;; create a callsite object, store it in the info db, and return the +;; fdefn. +;; +;; 3. Now we know that the types don't match we need to use adapters. +;; First again, we look at existing adapters and reuse them if possible. +;; +;; 4. An adapter is created that boxes the arguments and forwards the +;; call to the "normal" entry point. +;; +;; 5. If we are not allowed to create adapters, we look again at the +;; current definition to handle the case where no current definition +;; exists. If so, we return an empty fdefn object that will call the +;; undefined-tramp assembly routine. +;; +;; 6. If all else fails we link the callsite to our error handler. +;; +(declaim (ftype (function (t t) kernel:fdefn) find-typed-entry-point)) +(defun find-typed-entry-point (name callsite-typespec) + (let* ((cs-type (kernel:specifier-type callsite-typespec)) + (linkage (multiple-value-bind (info foundp) + (ext:info function linkage name) + (cond (foundp info) + (t (setf (ext:info function linkage name) + (make-linkage))))))) + (cond ((and nil (dolist (cs (listify (linkage-callsites linkage))) + (let* ((ep-type (callsite-type cs))) + (when (function-types-compatible-p cs-type ep-type) + (return (callsite-fdefn cs))))))) + ((let ((fdefn (fdefinition-object name nil))) + (when fdefn + (let ((fun (find-typed-entry-point-for-fdefn fdefn))) + (when fun + (let ((ep-type (kernel:extract-function-type fun))) + (when (function-types-compatible-p cs-type ep-type) + (let* ((aname (kernel:%function-name fun)) + (fdefn (kernel:make-fdefn aname)) + (cs (make-callsite :type cs-type :fdefn fdefn))) + (setf (kernel:fdefn-function fdefn) fun) + (push-unlistified cs (linkage-callsites linkage)) + fdefn)))))))) + ((or (not (lisp::fdefinition-object name nil)) + (not (kernel:fdefn-function + (lisp::fdefinition-object name nil)))) + (let* ((aname `(:typed-entry-point #:undefined)) + (fdefn (kernel:make-fdefn aname)) + (cs (make-callsite :type cs-type :fdefn fdefn))) + (push-unlistified cs (linkage-callsites linkage)) + fdefn)) + ((dolist (fun (listify (linkage-adapters linkage))) + (let ((ep-type (kernel:extract-function-type fun))) + (when (function-types-compatible-p cs-type ep-type) + (let* ((aname (kernel:%function-name fun)) + (fdefn (kernel:make-fdefn aname)) + (cs (make-callsite :type cs-type :fdefn fdefn))) + (setf (kernel:fdefn-function fdefn) fun) + (push-unlistified cs (linkage-callsites linkage)) + (return fdefn)))))) + (t + (let* ((fun (generate-adapter-function cs-type name)) + (fdefn (kernel:make-fdefn (kernel:%function-name fun))) + (cs (make-callsite :type cs-type :fdefn fdefn))) + (setf (kernel:fdefn-function fdefn) fun) + (push-unlistified fun (linkage-adapters linkage)) + (push-unlistified cs (linkage-callsites linkage)) + fdefn))))) + +(defun linkage-error (&rest args) + (declare (ignore args)) + (error "Linking callsite to typed-entry-point failed")) + +;; Generate an adapter function that changes the representation of the +;; arguments (specified with FTYPE) and forwards the call to NAME. +;; The adapter has also a typed entry point. It should also check +;; that the values returned by NAME match FTYPE. +;; +;; In practice, the compiler infered type may not match exactly FTYPE, +;; even if we add lotso declarations. This is annyoingly brittle. +(defun generate-adapter-function (ftype name) + (let* ((atypes (kernel:function-type-required ftype)) + (tmps (loop for nil in atypes collect (gensym))) + (fname `(:typed-entry-point + :boxing-adapter ,(make-symbol (string name)))) + (ftypespec (kernel:type-specifier ftype))) + (proclaim `(ftype ,ftypespec ,fname)) + (compile fname + `(lambda ,tmps + (declare + ,@(loop for tmp in tmps + for type in atypes + collect `(type ,(kernel:type-specifier type) ,tmp))) + (the ,(kernel:type-specifier + (kernel:function-type-returns ftype)) + (funcall (function ,name) . ,tmps)))) + (let ((fun (fdefinition fname))) + (unless (eq name 'linkage-error) + (fix-ftype fun ftype)) + fun))) + +(defun fix-ftype (fun ftype) + (let ((etype (kernel:extract-function-type fun))) + (unless (function-types-compatible-p ftype etype t) + (break))) + fun) + +;; This is our rule to decide when a type at a callsite matches the +;; type of the entry point. +;; +;; 1. The arguments at the callsite should be subtypes of the +;; arguments at the entry point. +;; +;; 2. The return value at the callsite should be supertypes of the +;; return values at the entry point. +;; +;; 3. The representations must agree. Representations should probably +;; decided in the backend, but for now we assume only double-floats +;; are unboxed. +(defun function-types-compatible-p (callsite-type entrypoint-type + &optional ignore-representation) + (flet ((return-types (ftype) + (let ((type (kernel:function-type-returns ftype))) + (cond ((kernel:values-type-p type) + (assert (and (not (kernel:values-type-rest type)) + (not (kernel:values-type-keyp type)))) + (kernel:values-type-required type)) + (t + (list type))))) + (ptype= (type1 type2) + (let ((double-float (kernel:specifier-type 'double-float))) + (cond (ignore-representation t) + ((kernel:type= type1 double-float) + (kernel:type= type2 double-float)) + ((kernel:type= type2 double-float) + nil) + (t t))))) + (and (every #'kernel:csubtypep + (kernel:function-type-required callsite-type) + (kernel:function-type-required entrypoint-type)) + (every #'ptype= + (kernel:function-type-required callsite-type) + (kernel:function-type-required entrypoint-type)) + (or + (and (every #'kernel:csubtypep + (return-types entrypoint-type) + (return-types callsite-type)) + (every #'ptype= + (return-types entrypoint-type) + (return-types callsite-type))) + (kernel:type= (kernel:function-type-returns entrypoint-type) + (kernel:specifier-type 'nil)))))) + + +;; check-function-redefinition is used as setf-fdefinition-hook. +;; We go through all existing callsites and +;; +;; 1. If the new type matches, we patch the callsite with the new function. +;; +;; 2. If the types don't match and if allowed, we redirect the +;; callsite to and adapter. +;; +;; 3. If the callsites doesn't want adapters we link the callsite to +;; an error handler. +(defun check-function-redefinition (name new-fun) + (multiple-value-bind (linkage foundp) (ext:info function linkage name) + (when foundp + (let* ((new-code (function-code-header new-fun)) + (new-tep (find-typed-entry-point-in-code new-code name)) + (new-type (extract-function-type new-tep))) + (dolist (cs (listify (linkage-callsites linkage))) + (let ((cs-type (callsite-type cs)) + (fdefn (callsite-fdefn cs))) + (cond ((function-types-compatible-p cs-type new-type) + (patch-fdefn fdefn new-tep)) + ((dolist (fun (listify (linkage-adapters linkage))) + (let ((ep-type (kernel:extract-function-type fun))) + (when (function-types-compatible-p cs-type ep-type) + (patch-fdefn fdefn fun) + (return t))))) + (t + (let ((fun (generate-adapter-function cs-type name))) + (push-unlistified fun (linkage-adapters linkage)) + (patch-fdefn fdefn fun)))))))))) + +;; This lets us set the name in fdefn objects. We use that for +;; debugging. +#-bootstrap +(eval-when (:compile-toplevel) + (c:defknown set-fdefn-name (kernel:fdefn t) t) + (c:def-setter set-fdefn-name vm:fdefn-name-slot vm:other-pointer-type)) + +(defun patch-fdefn (fdefn new-fun) + (setf (kernel:fdefn-function fdefn) new-fun) + (let ((name (kernel:%function-name new-fun))) + (set-fdefn-name fdefn name)) + fdefn) + +(pushnew 'check-function-redefinition ext:*setf-fdefinition-hook*) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index bed153e..3ba64a0 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1060,6 +1060,7 @@ (define-info-type function calling-convention symbol nil) +(define-info-type function lisp::linkage lisp::linkage nil) ); defun function-info-init commit 22b8ddc2a0f8280d586c8bc3bdadd6f290f1bfa2 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:46:25 2012 +0200 Add a new fop to find typed entries at load-time. The function of a %type-call is loaded with the new vop. diff --git a/src/code/load.lisp b/src/code/load.lisp index b5f591d..11a20ec 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -1519,4 +1519,10 @@ code-object)) +(define-fop (fop-typed-entry-point 151) + (let ((type (pop-stack)) + (name (pop-stack))) + (find-typed-entry-point name type))) + + (declaim (maybe-inline read-byte)) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index ac95c2e..c3b2ed0 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -521,7 +521,12 @@ (dump-push (cdr entry) file)) (:fdefinition (dump-object (cdr entry) file) - (dump-fop 'lisp::fop-fdefinition file)))) + (dump-fop 'lisp::fop-fdefinition file)) + (:typed-entry-point + (destructuring-bind (name ftype) (cdr entry) + (dump-object name file) + (dump-object (type-specifier ftype) file) + (dump-fop 'lisp::fop-typed-entry-point file))))) (null (dump-fop 'lisp::fop-misc-trap file))))) diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index bcc29de..459c6bc 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -203,7 +203,13 @@ (cdr const) object)) (:fdefinition (setf (code-header-ref code-obj index) - (lisp::fdefinition-object (cdr const) t)))))))))) + (lisp::fdefinition-object (cdr const) t))) + (:typed-entry-point + (destructuring-bind (name ftype) (cdr const) + (let ((typespec (type-specifier ftype))) + (setf (code-header-ref code-obj index) + (lisp::find-typed-entry-point name typespec))))) + ))))))) (undefined-value)) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 9232a1e..8bf1517 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -568,6 +568,14 @@ (annotate-ordinary-continuation value policy)) + +(defoptimizer (%typed-call ltn-annotate) ((&rest args) node policy) + (let ((fdefn (combination-fun node))) + (annotate-function-continuation fdefn policy t) + (dolist (arg args) + (annotate-ordinary-continuation arg policy)))) + + ;;;; Known call annotation: ;;; OPERAND-RESTRICTION-OK -- Interface commit c3efc0277e5e4645ee10d82acbf9db1c082c9c3d Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:42:41 2012 +0200 Generate special ir2 for %typed-calls. Define the vop and export it. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index cb91814..060ad89 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1759,8 +1759,9 @@ "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN" "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" - "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" - "TYPED-ENTRY-POINT-ALLOCATE-FRAME" "TYPED-CALL-LOCAL" + "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" + "TYPED-CALL-LOCAL" "TYPED-CALL-NAMED" + "TYPED-ENTRY-POINT-ALLOCATE-FRAME" "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNWIND" "UWP-ENTRY" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST" diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index e7efcb0..d1aa8b5 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1768,6 +1768,35 @@ compilation policy") (move-continuation-result node block (list val) (node-cont node)))) +(defun typed-entry-point-continuation-tn (fun ftype) + (declare (type continuation fun) (type function-type ftype)) + (let ((2cont (continuation-info fun))) + (assert (eq (ir2-continuation-kind 2cont) :delayed)) + (let ((name (continuation-function-name fun t))) + (assert name) + (make-load-time-constant-tn :typed-entry-point (list name ftype))))) + +(defoptimizer (%typed-call ir2-convert) ((&rest args) node block) + (let* ((fun (combination-fun node)) + (ftype (continuation-derived-type fun)) + (cont (node-cont node))) + (check-type ftype function-type) + (multiple-value-bind (arg-tns result-tns + fp stack-frame-size + nfp number-stack-frame-size) + (make-typed-call-tns ftype) + (declare (ignore number-stack-frame-size)) + (let ((fdefn-tn (typed-entry-point-continuation-tn fun ftype)) + (cont-tns (loop for arg in args + collect (continuation-tn node block arg)))) + (vop allocate-frame node block nil fp nfp) + (vop* typed-call-named node block + (fp nfp fdefn-tn (reference-tn-list cont-tns nil)) + ((reference-tn-list result-tns t)) + arg-tns stack-frame-size) + (move-continuation-result node block result-tns cont))))) + + ;;; IR2-Convert -- Interface ;;; ;;; Convert the code in a component into VOPs. diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 835ffe8..90d9259 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -1149,6 +1149,46 @@ (inst jmp (make-fixup 'tail-call-variable :assembly-routine)))) +(define-vop (typed-call-named) + (:args (new-fp) + (new-nfp) + (fdefn :scs (descriptor-reg control-stack) + :target eax) + (args :more t :scs (descriptor-reg))) + (:results (results :more t)) + (:save-p t) + (:move-args :local-call) + (:vop-var vop) + (:info arg-locs real-frame-size) + (:ignore new-nfp args arg-locs results) + (:temporary (:sc descriptor-reg :offset eax-offset) + eax) + (:generator 30 + ;; FIXME: allocate the real frame size here. We had to emit + ;; ALLOCATE-FRAME before this vop so that we can use the + ;; (:move-args :local-call) option here. Without the + ;; ALLOCATE-FRAME vop we get a failed assertion. + (inst lea esp-tn (make-ea :dword :base new-fp + :disp (- (* real-frame-size word-bytes)))) + + ;; Move fdefn to eax before switching frames. + (move eax fdefn) + + ;; Write old frame pointer (epb) into new frame. + (storew ebp-tn new-fp (- (1+ ocfp-save-offset))) + + ;; Switch to new frame. + (move ebp-tn new-fp) + + (note-this-location vop :call-site) + + ;; Load address out of fdefn and call it. + (inst call (make-ea :dword :base eax + :disp (- (* fdefn-raw-addr-slot word-bytes) + other-pointer-type))) + + )) + ;;;; Unknown values return: ;;; Return a single-value using the Unknown-Values convention. Specifically, commit 6b7a5961da54835daeaaee11d9e9c74164c9dd69 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:38:13 2012 +0200 Update some places that require type/name of XEPs. The functional-entry-function of a XEP may now be a typed entry point but the old code assumed that its the main lambda. diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 1164062..8a8c18f 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -33,7 +33,7 @@ (let ((2comp (component-info component))) (dolist (fun (component-lambdas component)) (when (or (external-entry-point-p fun) - (getf (lambda-plist fun) :entry-point)) + (typed-entry-point-p fun)) (let ((info (or (leaf-info fun) (setf (leaf-info fun) (make-entry-info))))) (compute-entry-info fun info) @@ -108,16 +108,21 @@ ;;; (defun compute-entry-info (fun info) (declare (type clambda fun) (type entry-info info)) - (let ((bind (lambda-bind fun)) - (internal-fun (functional-entry-function fun))) + (let* ((bind (lambda-bind fun)) + (internal-fun (functional-entry-function fun)) + (internal-fun (cond ((typed-entry-point-p internal-fun) + (functional-entry-function internal-fun)) + (t internal-fun))) + (tep (typed-entry-point-p fun))) (setf (entry-info-closure-p info) (not (null (environment-closure (lambda-environment fun))))) (setf (entry-info-offset info) (gen-label)) (setf (entry-info-name info) (let ((name (leaf-name internal-fun))) - (or name - (component-name (block-component (node-block bind)))))) - (when (policy bind (>= debug 1)) + (cond (tep (list :typed-entry-point name)) + (name) + (t (component-name (block-component (node-block bind))))))) + (when (or (policy bind (>= debug 1)) tep) (setf (entry-info-arguments info) (make-arg-names internal-fun)) (setf (entry-info-type info) (type-specifier (leaf-type internal-fun))))) (undefined-value)) @@ -146,6 +151,9 @@ (case (functional-kind lambda) (:external (let* ((ef (functional-entry-function lambda)) + (ef (cond ((typed-entry-point-p ef) + (functional-entry-function ef)) + (t ef))) (new (make-functional :kind :top-level-xep :info (leaf-info lambda) :name (leaf-name ef) diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index 3772243..0e924ab 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -62,6 +62,9 @@ ;;; (defun finalize-xep-definition (fun) (let* ((leaf (functional-entry-function fun)) + (leaf (if (typed-entry-point-p leaf) + (functional-entry-function leaf) + leaf)) (name (leaf-name leaf)) (dtype (definition-type leaf))) (setf (leaf-type leaf) dtype) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 0528787..1082202 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1531,7 +1531,10 @@ (defun main-entry (functional) (declare (type functional functional) (values clambda)) (etypecase functional - (clambda functional) + (clambda + (cond ((typed-entry-point-p functional) + (lambda-entry-function functional)) + (t functional))) (optional-dispatch (optional-dispatch-main-entry functional)))) @@ -1568,7 +1571,6 @@ (declare (type functional fun)) (not (null (member (functional-kind fun) '(:external :top-level))))) - ;;; Continuation-Function-Name -- Interface ;;; ;;; If Cont's only use is a non-notinline global function reference, then commit 7db4f90521a52676d4aaa244dbc7964c91b68bce Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:31:53 2012 +0200 Add a function typed-entry-point-p to abstract a bit from representation. diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index c39f17e..0528787 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1518,6 +1518,11 @@ ;;;; Functional hackery: +(defun typed-entry-point-p (fun) + (and (lambda-p fun) + (eq (getf (lambda-plist fun) :entry-point) + :typed))) + ;;; Main-Entry -- Interface ;;; ;;; If Functional is a Lambda, just return it; if it is an commit d75cd3b8e4f8681f55cd54461d8a8ac79d5e1662 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:26:58 2012 +0200 In probable-type-check-p, request type checking for the new convention. With the typed convention the type checks should be performed in the caller (normal :full calls check types in the callee). :simple checks will be performed by he move-arg vops the :hairy cases are done checkgen. diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index eaa4572..6d4fc6b 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -379,7 +379,12 @@ (let ((kind (basic-combination-kind dest))) (cond ((eq cont (basic-combination-fun dest)) t) ((eq kind :local) t) - ((member kind '(:full :error)) nil) + ((member kind '(:full :error)) + (let ((name (continuation-function-name + (combination-fun dest)))) + (cond ((info function calling-convention name) + t) + (t nil)))) ((function-info-ir2-convert kind) t) (t (dolist (template (function-info-templates kind) nil) commit 0000513f96308b121cd04329dd99ebd530dd3e2b Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Sat Jun 16 23:18:05 2012 +0200 In recognize-known-call, look at the calling-convention. If basic-combination-kind to the function-finfo of %typed-call. Struct accessors/setters are handled similarily. The problem with this approach is that we can't have transforms/optmizers etc. when the type calling convention is used. Add a function-info attribute to handle that case (not implemented yet). diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 5229915..cce9f37 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1332,3 +1332,6 @@ (defknown (compiler-warning compiler-note compiler-mumble) (string &rest t) (values) ()) + +(defknown %typed-call (&rest t) * + (typed-calling-convention)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 371617a..1ded755 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -948,7 +948,13 @@ (if (consp name) '%slot-setter '%slot-accessor) - name)))) + name))) + (cc (info function calling-convention name)) + (info (ecase cc + ((nil) info) + (:typed (cond ((not info) + (info function info '%typed-call)) + (t (error "nyi"))))))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil))))))) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 609d3e7..8c16208 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -82,6 +82,9 @@ ;; ;; Safe to stack-allocate function args that are closures. dynamic-extent-closure-safe + ;; + ;; + typed-calling-convention ) (defstruct (function-info commit 2d6b37b5c53b89e6b31e56d4b6e1a4ae57c9ffa6 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 21:59:57 2012 +0200 Boot hack: define calling-convention before compiling compiler. diff --git a/src/tools/cross-scripts/cross-x86-x86.lisp b/src/tools/cross-scripts/cross-x86-x86.lisp index 6a57fd2..87c2dad 100644 --- a/src/tools/cross-scripts/cross-x86-x86.lisp +++ b/src/tools/cross-scripts/cross-x86-x86.lisp @@ -46,6 +46,12 @@ (export 'vm::fixup-code-object "VM") (export 'vm::sanctify-for-execution "VM") +;; +(unless (find "CALLING-CONVENTION" + (c::class-info-types (gethash "FUNCTION" c::*info-classes*)) + :key #'c::type-info-name :test #'equal) + (c::define-info-type function c::calling-convention symbol nil)) + (comf "target:code/exports") (load "target:tools/comcom") @@ -217,3 +223,4 @@ (let ((ht (c::backend-sc-names c::*target-backend*))) (setf (gethash 'old-vm::any-reg ht) (gethash 'vm::any-reg ht))) + commit 459e3993717bb3cbedb4547d4a5004877003d40b Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 21:59:08 2012 +0200 Use x86-make-number-stack-pointer-tn instead of make-number-stack-pointer-tn. diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 151ea2f..835ffe8 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -215,7 +215,7 @@ (cond ((<= (getf state :reg-args) register-arg-count) (let ((n (getf state :reg-args))) (incf (getf state :reg-args)) - (standard-argument-location n))) + (x86-standard-argument-location n))) (t (make-wired-tn (ptype 't) control-stack-sc-number @@ -244,10 +244,10 @@ collect (arg-tn type arg-state)) (loop for type in rtypes collect (ret-tn type ret-state)) - (make-stack-pointer-tn) + (x86-make-stack-pointer-tn) (max (getf arg-state :frame-size) (getf ret-state :frame-size)) - (make-number-stack-pointer-tn) + (x86-make-number-stack-pointer-tn) 0)))) commit 2b0a11e7fce8dd7e0204c7ad309c746860ee24be Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 21:28:28 2012 +0200 Compile target:code/exports before comcom. Apparently needed now that export no longer acts at compile time. diff --git a/src/tools/cross-scripts/cross-x86-x86.lisp b/src/tools/cross-scripts/cross-x86-x86.lisp index aa4d84d..6a57fd2 100644 --- a/src/tools/cross-scripts/cross-x86-x86.lisp +++ b/src/tools/cross-scripts/cross-x86-x86.lisp @@ -46,6 +46,8 @@ (export 'vm::fixup-code-object "VM") (export 'vm::sanctify-for-execution "VM") +(comf "target:code/exports") + (load "target:tools/comcom") ;;; Load the new backend. commit 4983d20da4badfe2de5266bfbe580ac655ca7955 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 20:28:43 2012 +0200 Remove some random (load "target:code/exports"). diff --git a/Makefile b/Makefile index d409908..808ba2a 100644 --- a/Makefile +++ b/Makefile @@ -68,7 +68,6 @@ XSETUP=' \ (intl::install) \ (setf (ext:search-list "target:") \ (quote ("$(1)/" "src/"))) \ -(load "target:code/exports") \ (load "target:tools/setup" :if-source-newer :load-source) \ (comf "target:tools/setup" :load t) \ (setq *gc-verbose* nil *interactive* nil) \ @@ -169,13 +168,12 @@ xcompiler: $(CROSSCORE) $(BUILDDIR)/xcompiler/cross-%.core: $(MAKE) sanity - rm -rf $(XCOMPILERDIR) # yes, sucks, but that's the way it is + rm -rf $(XCOMPILERDIR) mkdir -vp $(BUILDDIR) if [ ! -e $(BUILDDIR)/src ] ; then \ ln -s $(TOPDIR)/src $(BUILDDIR)/src ; \ fi $(BINDIR)/create-target.sh $(XCOMPILERDIR) - mkdir -vp $(XCOMPILERDIR)/compiler/jvm cp -v $(TOOLSDIR)/cross-scripts/$(subst .core,.lisp,$(notdir $@)) \ $(XCOMPILERDIR)/cross.lisp $(BOOTCMUCL) -noinit -nositeinit \ @@ -183,7 +181,6 @@ $(BUILDDIR)/xcompiler/cross-%.core: -eval '(setf lisp::*enable-package-locked-errors* nil)' \ -eval '(intl::install)' \ -eval '$(call SET_TARGET_SEARCH_LIST, "$(XCOMPILERDIR)/")' \ --eval '(load "target:code/exports")' \ -eval '(load "target:tools/setup" :if-source-newer :load-source)' \ -eval '(comf "target:tools/setup" :load t)' \ -eval '(setq *gc-verbose* nil *interactive* nil)' \ commit 0c334764a1812bbc71c30ea964f8cb86360b7729 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 20:25:51 2012 +0200 Add a new info type: calling-convention Make defuns with a calling-convention declaration known the info db. diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index ae7b565..bed153e 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1058,6 +1058,8 @@ (define-info-type function definition t nil) +(define-info-type function calling-convention symbol nil) + ); defun function-info-init diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 2c70f62..f4ce61d 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -3990,7 +3990,14 @@ (lambda (second def)) (*current-path* (revert-source-path 'defun)) (expansion (unless (eq (info function inlinep name) :notinline) - (inline-syntactic-closure-lambda lambda)))) + (inline-syntactic-closure-lambda lambda))) + (decls (nth-value 1 (system:parse-body (cddr lambda) + *lexical-environment* t))) + (convention (find-declaration 'calling-convention decls 1 0))) + (cond (convention + (setf (info function calling-convention name) convention)) + (t + (clear-info function calling-convention name))) ;; ;; If not in a simple environment or :notinline, then discard any forward ;; references to this function. commit 8eb8276f55954d01f81fc1b5b88db564b934de6c Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 20:23:39 2012 +0200 Export new vops from VM package. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index a46d5bb..cb91814 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1759,7 +1759,9 @@ "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN" "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" - "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE" + "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" + "TYPED-ENTRY-POINT-ALLOCATE-FRAME" "TYPED-CALL-LOCAL" + "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNWIND" "UWP-ENTRY" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST" "VERIFY-ARGUMENT-COUNT" "WRITE-PACKED-BIT-VECTOR" commit 7ce2afa859e8429837a4c69564e822762ff461fa Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 20:22:10 2012 +0200 Create actual entry in code object for typed entry. Also make it possible to call the typed entry from XEP. diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index f5ec8ba..1164062 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -32,11 +32,14 @@ (defun entry-analyze (component) (let ((2comp (component-info component))) (dolist (fun (component-lambdas component)) - (when (external-entry-point-p fun) + (when (or (external-entry-point-p fun) + (getf (lambda-plist fun) :entry-point)) (let ((info (or (leaf-info fun) (setf (leaf-info fun) (make-entry-info))))) (compute-entry-info fun info) - (push info (ir2-component-entries 2comp)))))) + (push info (ir2-component-entries 2comp)) + (when (getf (lambda-plist fun) :entry-point) + (setf (getf (lambda-plist fun) :code-start) (gen-label))))))) (select-component-format component) (undefined-value)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 6c2dc48..e7efcb0 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -903,6 +903,25 @@ compilation policy") (move-continuation-result node block locs cont))))) (undefined-value)) +(defun ir2-convert-local-typed-call (node block fun cont) + (declare (type node node) (type ir2-block block) (type clambda fun) + (type continuation cont)) + (let ((ftype (the function-type (lambda-type fun))) + (args (basic-combination-args node)) + (start (getf (lambda-plist fun) :code-start))) + (multiple-value-bind (arg-tns result-tns + fp stack-frame-size + nfp number-stack-frame-size) + (make-typed-call-tns ftype) + (declare (ignore number-stack-frame-size)) + (let ((cont-tns (loop for arg in args + collect (continuation-tn node block arg)))) + (vop allocate-frame node block nil fp nfp) + (vop* typed-call-local node block + (fp nfp (reference-tn-list cont-tns nil)) + ((reference-tn-list result-tns t)) + arg-tns stack-frame-size start) + (move-continuation-result node block result-tns cont))))) ;;; IR2-Convert-Local-Call -- Internal ;;; @@ -931,8 +950,13 @@ compilation policy") (:unknown (ir2-convert-local-unknown-call node block fun cont start)) (:fixed - (ir2-convert-local-known-call node block fun returns - cont start))))))) + (ecase (getf (lambda-plist fun) :entry-point) + ((nil) + (ir2-convert-local-known-call node block fun returns + cont start)) + (:typed + (assert (external-entry-point-p (node-home-lambda node))) + (ir2-convert-local-typed-call node block fun cont))))))))) (undefined-value)) @@ -1178,6 +1202,18 @@ compilation policy") (undefined-value)) +;; arguments are wired to specific locations in gtn so we should have +;; to move them here. +(defun init-typed-entry-point-environment (node block fun) + (declare (type bind node) (type ir2-block block) (type clambda fun)) + (let ((start-label (entry-info-offset (leaf-info fun))) + (code-label (getf (lambda-plist fun) :code-start)) + (env (environment-info (node-environment node)))) + (vop typed-entry-point-allocate-frame node block + start-label code-label) + (vop setup-environment node block start-label) + (emit-move node block (make-old-fp-passing-location t) + (ir2-environment-old-fp env)))) ;;; IR2-Convert-Bind -- Internal ;;; @@ -1202,6 +1238,9 @@ compilation policy") (vop count-me node block *dynamic-counts-tn* (block-number (ir2-block-block block))))) + (when (getf (lambda-plist fun) :entry-point) + (init-typed-entry-point-environment node block fun)) + (emit-move node block (ir2-environment-return-pc-pass env) (ir2-environment-return-pc env)) diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index a5e9996..151ea2f 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -203,7 +203,7 @@ (double-float-arg (state) (cond ((<= (getf state :xmms-reg) xmm7-offset) (make-wired-tn (ptype 'double-float) - double-reg-sc-number + double-reg-sc-number (prog1 (getf state :xmms-reg) (incf (getf state :xmms-reg))))) (t @@ -216,7 +216,7 @@ (let ((n (getf state :reg-args))) (incf (getf state :reg-args)) (standard-argument-location n))) - (t + (t (make-wired-tn (ptype 't) control-stack-sc-number (prog1 (getf state :frame-size) @@ -230,7 +230,7 @@ (t (boxed-arg state)))) (ret-tn (type state) (let ((tn (arg-tn type state))) - (assert (member (sc-name (tn-sc tn)) + (assert (member (sc-name (tn-sc tn)) '(double-reg descriptor-reg))) tn))) (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) @@ -299,6 +299,34 @@ (trace-table-entry trace-table-normal))) +(define-vop (typed-entry-point-allocate-frame) + (:info start-label code-label) + (:vop-var vop) + (:generator 1 + ;; Make sure the function is aligned (using NOPs), and drop a + ;; label pointing to this function header. + (align lowtag-bits #x90) + (trace-table-entry trace-table-function-prologue) + (emit-label start-label) + ;; Skip space for the function header. + (inst function-header-word) + (dotimes (i (1- vm:function-code-offset)) + (inst dword 0)) + + ;; The start of the actual code. + (emit-label code-label) + + ;; Save the return-pc. + (popw ebp-tn (- (1+ return-pc-save-offset))) + + ;; The args fit within the frame so just allocate the frame. + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp (- (* vm:word-bytes + (sb-allocated-size 'stack))))) + + (trace-table-entry trace-table-normal))) + ;;; This is emitted directly before either a known-call-local, call-local, ;;; or a multiple-call-local. All it does is allocate stack space for the ;;; callee (who has the same size stack as us). @@ -732,6 +760,38 @@ RETURN (note-this-location vop :known-return) (trace-table-entry trace-table-normal))) + + +(define-vop (typed-call-local) + (:args (new-fp) + (new-nfp) + (args :more t)) + (:results (results :more t)) + (:save-p t) + (:move-args :local-call) + (:vop-var vop) + (:info arg-locs real-frame-size target) + (:ignore new-nfp args arg-locs results) + (:generator 30 + ;; FIXME: allocate the real frame size here. We had to emit + ;; ALLOCATE-FRAME before this vop so that we can use the + ;; (:move-args :local-call) option here. Without the + ;; ALLOCATE-FRAME vop we get a failed assertion. + (inst lea esp-tn (make-ea :dword :base new-fp + :disp (- (* real-frame-size word-bytes)))) + + ;; Write old frame pointer (epb) into new frame. + (storew ebp-tn new-fp (- (1+ ocfp-save-offset))) + + ;; Switch to new frame. + (move ebp-tn new-fp) + + (note-this-location vop :call-site) + + (inst call target) + + )) + ;;; Return from known values call. We receive the return locations as ;;; arguments to terminate their lifetimes in the returning function. We commit 3a28ef3ac0db9745535a18659530b8ba060a2636 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 20:10:06 2012 +0200 Assign lambda vars to the TNs as indicated by make-typed-call-tns. For lambdas with the (entry-point :typed) declaration we wire the arguments to the locations as dictated by the typed convention. diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 99d3e13..39d9b17 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -50,6 +50,15 @@ ;;; (defun assign-lambda-var-tns (fun let-p) (declare (type clambda fun)) + (ecase (getf (lambda-plist fun) :entry-point) + ((nil) + (assign-normal-lambda-var-tns fun let-p)) + (:typed + (assign-typed-lambda-var-tns fun))) + (undefined-value)) + +(defun assign-normal-lambda-var-tns (fun let-p) + (declare (type clambda fun)) (dolist (var (lambda-vars fun)) (when (leaf-refs var) (let* ((type (if (lambda-var-indirect var) @@ -64,9 +73,16 @@ (environment-debug-live-tn temp (lambda-environment fun))))) (setf (tn-leaf res) var) - (setf (leaf-info var) res)))) - (undefined-value)) + (setf (leaf-info var) res))))) +(defun assign-typed-lambda-var-tns (fun) + (declare (type clambda fun)) + (let ((ftype (lambda-type fun))) + (loop for var in (lambda-vars fun) + for tn in (make-typed-call-tns ftype) + do (when (leaf-refs var) + (setf (tn-leaf tn) var) + (setf (leaf-info var) tn))))) ;;; Assign-IR2-Environment -- Internal ;;; @@ -95,7 +111,7 @@ (make-old-fp-save-location env)) (setf (ir2-environment-return-pc res) (make-return-pc-save-location env))))) - + (undefined-value)) @@ -188,6 +204,21 @@ ;;; reason. Otherwise we allocate passing locations for a fixed number of ;;; values. ;;; +(defun choose-return-locations (fun) + (declare (type clambda fun)) + (ecase (getf (lambda-plist fun) :entry-point) + ((nil) + (let* ((tails (lambda-tail-set fun)) + (ep (find-if (lambda (fun) + (getf (lambda-plist fun) :entry-point)) + (tail-set-functions tails)))) + (cond (ep + (return-info-for-typed-convention ep)) + (t + (return-info-for-set tails))))) + (:typed + (return-info-for-typed-convention fun)))) + (defun return-info-for-set (tails) (declare (type tail-set tails)) (multiple-value-bind (types count) @@ -204,6 +235,14 @@ :types ptypes :locations (mapcar #'make-normal-tn ptypes)))))) +(defun return-info-for-typed-convention (fun) + (declare (type clambda fun)) + (let* ((ftype (lambda-type fun)) + (tns (nth-value 1 (make-typed-call-tns ftype)))) + (make-return-info :kind :fixed + :count (length tns) + :types (mapcar #'tn-primitive-type tns) + :locations tns))) ;;; Assign-Return-Locations -- Internal ;;; @@ -217,7 +256,7 @@ (let* ((tails (lambda-tail-set fun)) (returns (or (tail-set-info tails) (setf (tail-set-info tails) - (return-info-for-set tails)))) + (choose-return-locations fun)))) (return (lambda-return fun))) (when (and return (not (eq (return-info-kind returns) :unknown)) @@ -226,7 +265,6 @@ (setf (node-tail-p use) nil)))) (undefined-value)) - ;;; Assign-IR2-NLX-Info -- Internal ;;; ;;; Make an IR2-NLX-Info structure for each NLX entry point recorded. We commit 3a0e00cc698c7e4f70e90afb218b4db8413d5953 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 20:03:30 2012 +0200 Create special entry point if indicated. If a lambda has a (calling-convention :typed) declartion we create a the special entry point. diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 9d5a54d..6882f92 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -143,17 +143,31 @@ (declare (type functional fun)) (etypecase fun (clambda - (let ((nargs (length (lambda-vars fun))) - (n-supplied (gensym))) - (collect ((temps)) - (dotimes (i nargs) - (temps (gensym))) - `(lambda (,n-supplied ,@(temps)) - (declare (type index ,n-supplied)) - ,(if (policy nil (zerop safety)) - `(declare (ignore ,n-supplied)) - `(%verify-argument-count ,n-supplied ,nargs)) - (%funcall ,fun ,@(temps)))))) + (let* ((nargs (length (lambda-vars fun))) + (n-supplied (gensym)) + (temps (loop repeat nargs collect (gensym))) + (fun (ecase (getf (lambda-plist fun) :calling-convention) + ((nil) fun) + (:typed + (let ((fun2 (ir1-convert-lambda + `(lambda ,temps + (declare (entry-point :typed)) + ,@(loop for tmp in temps + for var in (lambda-vars fun) + collect + `(declare (type + ,(type-specifier + (lambda-var-type var)) + ,tmp))) + (%funcall ,fun . ,temps))))) + (setf (lambda-entry-function fun) fun2) + fun2))))) + `(lambda (,n-supplied . ,temps) + (declare (type index ,n-supplied)) + ,(if (policy nil (zerop safety)) + `(declare (ignore ,n-supplied)) + `(%verify-argument-count ,n-supplied ,nargs)) + (%funcall ,fun . ,temps)))) (optional-dispatch (let* ((min (optional-dispatch-min-args fun)) (max (optional-dispatch-max-args fun)) @@ -208,8 +222,14 @@ (res (ir1-convert-lambda (make-xep-lambda fun)))) (setf (functional-kind res) :external) (setf (leaf-ever-used res) t) - (setf (functional-entry-function res) fun) - (setf (functional-entry-function fun) res) + (cond ((functional-entry-function fun) + (let ((ep (functional-entry-function fun))) + (setf (functional-entry-function ep) fun) + (setf (functional-entry-function fun) ep) + (setf (functional-entry-function res) ep))) + (t + (setf (functional-entry-function res) fun) + (setf (functional-entry-function fun) res))) (setf (component-reanalyze *current-component*) t) (setf (component-reoptimize *current-component*) t) (etypecase fun commit 505bdffd1297bd43509d8b234f77e9782cd57d12 Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 19:58:32 2012 +0200 Add a new vm-support-routine: make-typed-call-tns This defines register/representation to use for a given function type. diff --git a/src/compiler/backend.lisp b/src/compiler/backend.lisp index a8b063e..8f9f711 100644 --- a/src/compiler/backend.lisp +++ b/src/compiler/backend.lisp @@ -96,7 +96,11 @@ ;; For use with scheduler. emit-nop - location-number) + location-number + + make-typed-call-tns + +) (defprinter vm-support-routines) diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 63104de..a5e9996 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -187,6 +187,70 @@ (undefined-value)) +;; make-typed-call-tns chooses the representation for a function type. +;; This is similar to c::make-call-out-tns and should probably also be +;; a vm-support-routine. +;; +;; The current convention passes double-floats unboxed and all other +;; types remain boxed. Registers XMM4-XMM7 are used for the first 4 +;; double arguments. Boxed values are passed in standard locations. +;; +;; Returning values on the stack is currenlty not implemented, so all +;; return values must fit in registers. +(def-vm-support-routine make-typed-call-tns (ftype) + (declare (type function-type ftype)) + (labels ((ptype (name) (primitive-type-or-lose name *backend*)) + (double-float-arg (state) + (cond ((<= (getf state :xmms-reg) xmm7-offset) + (make-wired-tn (ptype 'double-float) + double-reg-sc-number + (prog1 (getf state :xmms-reg) + (incf (getf state :xmms-reg))))) + (t + (make-wired-tn (ptype 'double-float) + double-stack-sc-number + (prog1 (getf state :frame-size) + (incf (getf state :frame-size) 2)))))) + (boxed-arg (state) + (cond ((<= (getf state :reg-args) register-arg-count) + (let ((n (getf state :reg-args))) + (incf (getf state :reg-args)) + (standard-argument-location n))) + (t + (make-wired-tn (ptype 't) + control-stack-sc-number + (prog1 (getf state :frame-size) + (incf (getf state :frame-size) 1)))))) + (double-float-type-p (type) + (and (numeric-type-p type) + (eq (numeric-type-class type) 'float) + (eq (numeric-type-format type) 'double-float))) + (arg-tn (type state) + (cond ((double-float-type-p type) (double-float-arg state)) + (t (boxed-arg state)))) + (ret-tn (type state) + (let ((tn (arg-tn type state))) + (assert (member (sc-name (tn-sc tn)) + '(double-reg descriptor-reg))) + tn))) + (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) + (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0)) + (returns (function-type-returns ftype)) + (rtypes (typecase returns + (values-type (values-type-required returns)) + (t (list returns))))) + (values + (loop for type in (function-type-required ftype) + collect (arg-tn type arg-state)) + (loop for type in rtypes + collect (ret-tn type ret-state)) + (make-stack-pointer-tn) + (max (getf arg-state :frame-size) + (getf ret-state :frame-size)) + (make-number-stack-pointer-tn) + 0)))) + + ;;;; Frame hackery: ;;; Used for setting up the Old-FP in local call. commit 24495066a479bc6a889b4402e2f78d7cb09e096c Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Fri Jun 15 19:51:22 2012 +0200 Add declarations: calling-convention and entry-point. We use two new declarations for lambda to choose the calling convention. diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 81c7d74..2c70f62 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -142,6 +142,19 @@ (member (car y) '(flet labels)) (equal x (cadr y))))) +(declaim (declaration calling-convention)) +(declaim (declaration entry-point)) + +(defun find-declaration (name declarations &optional argcount nth) + (loop for (nil . decls) in declarations do + (loop for d in decls + for (decl-name . values) = d + do (when (eq decl-name name) + (when argcount + (assert (= (length values) argcount))) + (return-from find-declaration + (cond (nth (nth nth values)) + (t d))))))) ;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the ;;; insertion a (CATCH ...) around code to allow the debugger @@ -1570,6 +1583,9 @@ (process-declarations (append context-decls decls) (append aux-vars vars) nil cont)) + (calling-convention (find-declaration 'calling-convention decls + 1 0)) + (entry-point (find-declaration 'entry-point decls 1 0)) (res (if (or (find-if #'lambda-var-arg-info vars) keyp) (ir1-convert-hairy-lambda new-body vars keyp allow-other-keys @@ -1590,6 +1606,11 @@ (and decl (eq 'declare (first decl)) (cons 'pcl::method (cadadr decl)))))) + (when calling-convention + (setf (getf (lambda-plist res) :calling-convention) + calling-convention)) + (when entry-point + (setf (getf (lambda-plist res) :entry-point) entry-point)) res)))) commit c10c63de861542c04cdb378274231890f3118e9e Author: Helmut Eller <eller.helmut(a)gmail.com> Date: Mon Jun 11 22:34:57 2012 +0200 Add my Makefile. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..d409908 --- /dev/null +++ b/Makefile @@ -0,0 +1,388 @@ +# Makefile to build cmucl + +TOPDIR := $(PWD) +TOOLSDIR := $(TOPDIR)/src/tools +BINDIR := $(TOPDIR)/bin +BUILDDIR := $(TOPDIR)/build +BOOTCMUCL := cmucl +XHOST := x86 +XTARGET := x86 +BOOTFILE := + +help: + @echo -e "\ +all -- world (= xcompiler+genesis+runtime+compiler+pcl)\n\ +help -- Print out help information\n\ +help-vars -- Information about make variables\n\ +help-other -- Information about rarely needed targets\n\ +world -- Create core file and C runtime\n\ +xcompiler -- Build a core file with cross-compiler loaded\n\ +genesis -- Cross-dump initial image (no compiler, no pcl) \n\ +runtime -- Build C runtime\n\ +compiler -- Build core file with compiler loaded\n\ +pcl -- Build core file with compiler+pcl loaded\n\ +stage2 -- Compile world again using compiler (no cross-compiler)\n\ +clean -- Remove build directory\ +" + +help-vars: + @echo -e "\ +TOPDIR directory containing src directory ($(TOPDIR))\n\ +TOOLSDIR directory with build scripts ($(TOOLSDIR))\n\ +BUILDDIR build directory ($(BUILDDIR))\n\ +BOOTCMUCL compiler used for bootstrap ($(BOOTCMUCL))\n\ +XHOST host system ($(XHOST))\n\ +XTARGET target system ($(XTARGET))\n\ +BOOTFILE file for bootstrap hacks (default: none)\ +" + +help-other: + @echo -e "\ +xcompile-world -- cross-compile library \n\ +xcompile-compiler -- cross-compile compiler \n\ +xdump-world -- cold-load library and cross-dump (genesis)\n\ +clean-world -- remove the build/world directory\n\ +sanity-clean -- remove fasl files in source directory\n\ +run-xcompiler -- open a REPL with the cross-compiler\ +" + +all: world + +XCOMPILERDIR := $(BUILDDIR)/xcompiler +KERNELDIR := $(BUILDDIR)/world +COMPILERDIR := $(BUILDDIR)/compiler +PCLDIR := $(BUILDDIR)/pcl +STAGE2DIR := $(BUILDDIR)/stage2 + +CROSSCORE := $(XCOMPILERDIR)/cross-$(XHOST)-$(XTARGET).core +KERNELCORE := $(KERNELDIR)/lisp/kernel.core +RUNTIME := $(KERNELDIR)/lisp/lisp +COMPILERCORE := $(COMPILERDIR)/lisp/compiler.core +PCLCORE := $(PCLDIR)/lisp/pcl.core +LISPCORE := $(KERNELDIR)/lisp/lisp.core +KERNELCORE2 := $(STAGE2DIR)/lisp/kernel.core +RUNTIME2 := $(STAGE2DIR)/lisp/lisp +LISPCORE2 := $(STAGE2DIR)/lisp/lisp.core + +XSETUP=' \ +(intl::install) \ +(setf (ext:search-list "target:") \ + (quote ("$(1)/" "src/"))) \ +(load "target:code/exports") \ +(load "target:tools/setup" :if-source-newer :load-source) \ +(comf "target:tools/setup" :load t) \ +(setq *gc-verbose* nil *interactive* nil) \ +' + +SETUP2=' \ +(intl::install) \ +(setq *compile-print* t) \ +(setq *load-verbose* t) \ +(load "target:setenv") \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(load "target:code/exports") \ +(load "target:tools/setup" :if-source-newer :load-source) \ +(comf "target:tools/setup" :load t) \ +(setq *gc-verbose* nil *interactive* nil) \ +' + +LOAD_BOOTFILE=' \ +(let ((bootfile "$(BOOTFILE)")) \ + (unless (equal bootfile "") \ + (load bootfile))) \ +' + +SET_TARGET_SEARCH_LIST=(setf (ext:search-list "target:") (list $(1) "src/")) + +XSETENV=' \ +$(call SET_TARGET_SEARCH_LIST,$(1)) \ +(pushnew :bootstrap *features*) \ +(load "target:setenv") \ +(pushnew :no-pcl *features*) \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +' + +#(load "target:tools/comcom") \ +#(comf "target:compiler/generic/new-genesis") \ + +LOAD_WORLD=' \ +(in-package :cl-user) \ +$(call SET_TARGET_SEARCH_LIST, "$(KERNELDIR)/") \ +(load "target:setenv") \ +(pushnew :no-compiler *features*) \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(pushnew :no-pcl *features*) \ +(load "target:tools/worldload") \ +' + +#(setf (ext:search-list "target:") \ +# (list "$(COMPILERDIR)/" "$(KERNELDIR)/" "src/")) \ + +LOAD_COMPILER=' \ +(in-package :cl-user) \ +$(call SET_TARGET_SEARCH_LIST,"$(COMPILERDIR)/" "$(KERNELDIR)/") \ +(load "target:setenv") \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(pushnew :no-pcl *features*) \ +(load "target:tools/worldload") \ +' + +COMPILE_PCL=' \ +(load "target:code/exports") \ +(pushnew :bootstrap *features*) \ +(load "target:setenv") \ +(pushnew :no-pcl *features*) \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(load "target:tools/pclcom") \ +' + +LOAD_PCL=' \ +(in-package :cl-user) \ +$(call SET_TARGET_SEARCH_LIST,"$(PCLDIR)/" "$(COMPILERDIR)/" "$(KERNELDIR)/") \ +(load "target:setenv") \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(load "target:tools/worldload") \ +' + +LOAD_PCL2=' \ +(in-package :cl-user) \ +$(call SET_TARGET_SEARCH_LIST,"$(STAGE2DIR)/") \ +(load "target:setenv") \ +(pushnew :no-clx *features*) \ +(pushnew :no-clm *features*) \ +(pushnew :no-hemlock *features*) \ +(load "target:tools/worldload") \ +' + +xcompiler: $(CROSSCORE) + +$(BUILDDIR)/xcompiler/cross-%.core: + $(MAKE) sanity + rm -rf $(XCOMPILERDIR) # yes, sucks, but that's the way it is + mkdir -vp $(BUILDDIR) + if [ ! -e $(BUILDDIR)/src ] ; then \ + ln -s $(TOPDIR)/src $(BUILDDIR)/src ; \ + fi + $(BINDIR)/create-target.sh $(XCOMPILERDIR) + mkdir -vp $(XCOMPILERDIR)/compiler/jvm + cp -v $(TOOLSDIR)/cross-scripts/$(subst .core,.lisp,$(notdir $@)) \ + $(XCOMPILERDIR)/cross.lisp + $(BOOTCMUCL) -noinit -nositeinit \ +-eval '(in-package :cl-user)' \ +-eval '(setf lisp::*enable-package-locked-errors* nil)' \ +-eval '(intl::install)' \ +-eval '$(call SET_TARGET_SEARCH_LIST, "$(XCOMPILERDIR)/")' \ +-eval '(load "target:code/exports")' \ +-eval '(load "target:tools/setup" :if-source-newer :load-source)' \ +-eval '(comf "target:tools/setup" :load t)' \ +-eval '(setq *gc-verbose* nil *interactive* nil)' \ +-eval '(load "$(XCOMPILERDIR)/cross.lisp")' \ +-eval '(remf ext::*herald-items* :python)' \ +-eval '(ext:save-lisp "$@" :purify nil)' \ +-eval '(ext:quit)' +# Strangeness 1: the -batch command line option breaks the build! +# Strangeness 2: if :purify is t, the compiler in the core file doesn't work + +xlisp: xcompiler + $(BOOTCMUCL) -core $(CROSSCORE) + +xcompile-world: $(KERNELDIR)/world.snapshot + +$(KERNELDIR)/world.snapshot: $(CROSSCORE) + $(MAKE) sanity + $(MAKE) clean-world + $(BINDIR)/create-target.sh $(KERNELDIR) + $(BOOTCMUCL) \ + -core $(CROSSCORE) \ + -noinit -nositeinit \ + -eval $(call XSETENV, "$(KERNELDIR)/") \ + -eval $(LOAD_BOOTFILE) \ + -eval '(load "target:tools/worldcom")' \ + -eval '(ext:save-lisp "$@" :purify nil)' \ + -eval '(ext:quit)' + +xcompile-compiler: $(COMPILERDIR)/compiler.snapshot + +$(COMPILERDIR)/compiler.snapshot: $(KERNELDIR)/world.snapshot + $(MAKE) sanity + $(MAKE) clean-compiler + $(BINDIR)/create-target.sh $(COMPILERDIR) + $(BOOTCMUCL) \ + -core $< \ + -noinit -nositeinit \ + -eval $(call XSETENV, "$(COMPILERDIR)/") \ + -eval $(LOAD_BOOTFILE) \ + -eval '(load "target:tools/comcom")' \ + -eval '(ext:save-lisp "$@" :purify nil)' \ + -eval '(ext:quit)' + +run-xcompiler: xcompiler + $(MAKE) sanity + $(BOOTCMUCL) \ + -core $(CROSSCORE) \ + -noinit \ + -eval $(call XSETENV, "$(KERNELDIR)/") \ + -eval $(SETUP_CROSS_COMPILER) \ + -eval $(LOAD_BOOTFILE) + +MOVECORE=cd $(1) &&\ + mv lisp.core $(2) \ + || mv lisp-sse2.core $(2) \ + || mv lisp-x87.core $(2) + +genesis: $(KERNELCORE) + +#$(CROSSCORE) +# $(MAKE) xcompile-world +# $(MAKE) xdump-world +# -eval '(load "target:tools/comcom")' \ +# -eval '(comf "target:compiler/generic/new-genesis")' \ + +$(KERNELCORE): $(KERNELDIR)/world.snapshot + $(BOOTCMUCL) \ + -core $(CROSSCORE) \ + -noinit \ + -eval $(call XSETENV, "$(KERNELDIR)/") \ + -eval '(load "target:tools/worldbuild")' \ + -eval '(quit)' + +compiler: $(COMPILERCORE) + +$(COMPILERCORE): $(KERNELCORE) $(RUNTIME) $(COMPILERDIR)/compiler.snapshot + echo $(LOAD_COMPILER) | $(RUNTIME) -core $(KERNELCORE) + $(call MOVECORE,$(COMPILERDIR)/lisp,$@) + +compile-pcl: $(PCLDIR)/pcl.stamp + +$(PCLDIR)/pcl.stamp: $(COMPILERCORE) + $(MAKE) sanity + $(MAKE) clean-pcl + $(BINDIR)/create-target.sh $(PCLDIR) + $(RUNTIME) \ + -core $(COMPILERCORE) \ + -noinit -nositeinit \ + -eval '$(call SET_TARGET_SEARCH_LIST,"$(PCLDIR)/")' \ + -eval $(SETUP2) \ + -eval $(COMPILE_PCL) \ + -eval '(ext:quit)' + touch $@ + +pcl: $(PCLCORE) + +$(PCLCORE): $(PCLDIR)/pcl.stamp + echo $(LOAD_PCL) | $(RUNTIME) -core $(KERNELCORE) + $(call MOVECORE,$(PCLDIR)/lisp,$@) + +runtime: $(RUNTIME) + +$(RUNTIME): $(KERNELDIR)/lisp ; + +$(KERNELDIR)/lisp: $(KERNELCORE) + $(MAKE) -C $(KERNELDIR)/lisp + +.PHONY: $(KERNELDIR)/lisp + +world: $(LISPCORE) + +$(LISPCORE): $(PCLCORE) + cp $< $@ + +compile-world2: $(KERNELCORE2) + +$(KERNELCORE2): $(COMPILERCORE) + $(MAKE) sanity + $(MAKE) clean-stage2 + $(BINDIR)/create-target.sh $(STAGE2DIR) + $(RUNTIME) \ + -core $(COMPILERCORE) \ + -noinit \ +-eval '(in-package :cl-user)' \ +-eval '(intl::install)' \ +-eval '$(call SET_TARGET_SEARCH_LIST, "$(STAGE2DIR)/")' \ +-eval '(load "target:setenv")' \ +-eval '(pushnew :no-clx *features*)' \ +-eval '(pushnew :no-clm *features*)' \ +-eval '(pushnew :no-hemlock *features*)' \ +-eval '(load "target:code/exports")' \ +-eval '(load "target:tools/setup" :if-source-newer :load-source)' \ +-eval '(comf "target:tools/setup" :load t)' \ +-eval '(setq *gc-verbose* nil *interactive* nil)' \ +-eval '(load "target:tools/worldcom")' \ +-eval '(load "target:tools/comcom")' \ +-eval '(load "target:tools/pclcom")' \ +-eval '(load "target:tools/worldbuild")' \ +-eval '(ext:quit)' + +runtime2: $(RUNTIME2) + +$(RUNTIME2): $(STAGE2DIR)/lisp ; + +$(STAGE2DIR)/lisp: $(KERNELCORE2) + $(MAKE) -C $(STAGE2DIR)/lisp + +.PHONY: $(STAGE2DIR)/lisp + +stage2: $(LISPCORE2) + +$(LISPCORE2): $(KERNELCORE2) $(RUNTIME2) + echo $(LOAD_PCL2) | $(RUNTIME2) -core $(KERNELCORE2) + $(call MOVECORE,$(STAGE2DIR)/lisp,$@) + +cross-build: + bin/create-target.sh xcross + bin/create-target.sh xtarget + cp src/tools/cross-scripts/cross-x86-x86.lisp xtarget/cross.lisp + bin/cross-build-world.sh xtarget xcross xtarget/cross.lisp $(BOOTCMUCL) + bin/rebuild-lisp.sh xtarget + bin/load-world.sh -p xtarget "newlisp" + +sanity: + @if [ `echo $(TOPDIR) | egrep -c '^/'` -ne 1 ]; then \ + echo "ERROR: TOPDIR must be an absolute path: $(TOPDIR)"; \ + exit 1; \ + fi + @if [ ! -r $(TOPDIR)/src/hemlock/abbrev.lisp ] ; then \ + echo "ERROR: No cmucl source tree available at: $(TOPDIR)"; \ + exit 1; \ + fi + @faslfiles=`find -L $(TOPDIR)/src/ -name "*.sse2f"` ; \ + if [ -n "$$faslfiles" ] ; then \ + echo ERROR: Source tree contains fasl files: "$$faslfiles"; \ + exit 1; \ + fi + +sanity-clean: + find -L $(TOPDIR)/src/ $ -name "*.sse2f" -o -name "*.bytef" $ \ + -exec rm -iv {} \; + +clean: sanity-clean + rm -rf $(BUILDDIR) + +clean-xcompiler: sanity-clean + rm -rf $(XCOMPILERDIR) + +clean-world: sanity-clean + rm -rf $(KERNELDIR) + +clean-compiler: sanity-clean + rm -rf $(COMPILERDIR) + +clean-pcl: sanity-clean + rm -rf $(PCLDIR) + +clean-stage2: sanity-clean + rm -rf $(STAGE2DIR) + +rebuild-xcompiler: sanity-clean clean-xcompiler xcompiler + ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch file-attribute created. snapshot-2012-06-4-g81f65db
by Raymond Toy 26 Jun '12

26 Jun '12

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs