From 5ced0fdfbbfff78e7fce9446628c15e552cab8a9 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 21 Jan 1997 00:30:28 +0000 Subject: [PATCH] source kit 1.03.7 --- assembly/x86/alloc.lisp | 70 ++ assembly/x86/arith.lisp | 318 ++++++ assembly/x86/array.lisp | 146 +++ assembly/x86/assem-rtns.lisp | 290 ++++++ assembly/x86/bit-bash.lisp | 1 + assembly/x86/kludges.lisp | 66 ++ assembly/x86/support.lisp | 62 ++ lisp/Config.FreeBSD | 19 + lisp/Config.linux | 20 + lisp/FreeBSD-os.c | 259 +++++ lisp/FreeBSD-os.h | 41 + lisp/GNUmakefile | 14 +- lisp/Linux-os.c | 274 +++++ lisp/Linux-os.h | 76 ++ lisp/WARNING.files | 9 + lisp/alloc.c | 16 +- lisp/cgc.c | 1902 ++++++++++++++++++++++++++++++++++ lisp/cgc.h | 7 + lisp/coreparse.c | 14 +- lisp/dynbind.c | 4 +- lisp/globals.c | 10 +- lisp/globals.h | 20 +- lisp/interr.c | 6 +- lisp/interrupt.c | 86 +- lisp/linux-stubs.S | 171 +++ lisp/lisp.c | 27 +- lisp/lisp.h | 10 +- lisp/monitor.c | 43 +- lisp/os.h | 10 +- lisp/parse.c | 12 +- lisp/print.c | 30 +- lisp/purify.c | 258 ++++- lisp/save.c | 27 +- lisp/undefineds.h | 25 +- lisp/validate.c | 6 +- lisp/x86-arch.c | 329 ++++++ lisp/x86-assem.S | 438 ++++++++ lisp/x86-lispregs.h | 45 + lisp/x86-validate.h | 29 + 39 files changed, 5064 insertions(+), 126 deletions(-) create mode 100644 assembly/x86/alloc.lisp create mode 100644 assembly/x86/arith.lisp create mode 100644 assembly/x86/array.lisp create mode 100644 assembly/x86/assem-rtns.lisp create mode 100644 assembly/x86/bit-bash.lisp create mode 100644 assembly/x86/kludges.lisp create mode 100644 assembly/x86/support.lisp create mode 100644 lisp/Config.FreeBSD create mode 100644 lisp/Config.linux create mode 100644 lisp/FreeBSD-os.c create mode 100644 lisp/FreeBSD-os.h create mode 100644 lisp/Linux-os.c create mode 100644 lisp/Linux-os.h create mode 100644 lisp/WARNING.files create mode 100644 lisp/cgc.c create mode 100644 lisp/cgc.h create mode 100644 lisp/linux-stubs.S create mode 100644 lisp/x86-arch.c create mode 100644 lisp/x86-assem.S create mode 100644 lisp/x86-lispregs.h create mode 100644 lisp/x86-validate.h diff --git a/assembly/x86/alloc.lisp b/assembly/x86/alloc.lisp new file mode 100644 index 000000000..e94733450 --- /dev/null +++ b/assembly/x86/alloc.lisp @@ -0,0 +1,70 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/alloc.lisp,v 1.1 1997/01/21 00:30:28 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Stuff to handle allocating simple objects. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski -- Spring 1995. +;;; +(in-package :x86) + + +;;;; From from signed/unsigned + +#+assembler ; we don't want a vop for this one. +(define-assembly-routine + (move-from-signed) + ((:temp eax dword-reg eax-offset) + (:temp ebx dword-reg ebx-offset) + (:temp ecx dword-reg ecx-offset)) + (inst mov ebx eax) + (inst shl ebx 1) + (inst jmp :o bignum) + (inst shl ebx 1) + (inst jmp :o bignum) + (inst ret) + BIGNUM + + (with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 1)) + (storew eax ebx bignum-digits-offset other-pointer-type)) + + (inst ret)) + +#+assembler ; we don't want a vop for this one either. +(define-assembly-routine + (move-from-unsigned) + ((:temp eax dword-reg eax-offset) + (:temp ebx dword-reg ebx-offset) + (:temp ecx dword-reg ecx-offset)) + + (inst test eax #xe0000000) + (inst jmp :nz bignum) + ;; Fixnum + (inst mov ebx eax) + (inst shl ebx 2) + (inst ret) + + BIGNUM + (inst jmp :ns one-word-bignum) + (inst mov ebx eax) + + ;; Two word bignum + (with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 2)) + (storew eax ebx bignum-digits-offset other-pointer-type)) + (inst ret) + + ONE-WORD-BIGNUM + (with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 1)) + (storew eax ebx bignum-digits-offset other-pointer-type)) + (inst ret)) diff --git a/assembly/x86/arith.lisp b/assembly/x86/arith.lisp new file mode 100644 index 000000000..38e2657cb --- /dev/null +++ b/assembly/x86/arith.lisp @@ -0,0 +1,318 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/arith.lisp,v 1.1 1997/01/21 00:30:28 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Stuff to handle simple cases for generic arithmetic. +;;; +;;; Written by William Lott. +;;; Debugged by Paul Werkowski -- Spring/Summer 1995. +;;; +(in-package :x86) + +(eval-when (compile eval) + + +;;;; Addition, Subtraction, and Multiplication + +(defmacro define-generic-arith-routine ((fun cost) &body body) + `(define-assembly-routine (,(symbolicate "GENERIC-" fun) + (:cost ,cost) + (:return-style :full-call) + (:translate ,fun) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) + ;; this seems wrong esi-offset + edi-offset) + + (:res res (descriptor-reg any-reg) edx-offset) + + (:temp eax dword-reg eax-offset) + (:temp ebx dword-reg ebx-offset) + (:temp ecx dword-reg ecx-offset)) + ;; for now, pass this off + ;; (inst jmp DO-STATIC-FUN) + ;; ebx ; ignorable + (inst test x 3) ; fixnum? + (inst jmp :nz DO-STATIC-FUN) ; no - do generic + (inst test y 3) ; fixnum? + (inst jmp :z DO-BODY) ; yes - doit here + + DO-STATIC-FUN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) + (inst sub esp-tn (fixnum 3)) ; pw -- was 2 + (inst push eax) ; callers return addr + (inst mov ecx (fixnum 2)) ; arg count + + (inst mov ebx + (make-ea :dword + :disp (+ nil-value (static-function-offset + ',(symbolicate "TWO-ARG-" fun))))) + + (inst jmp ebx) + + DO-BODY + ,@body)) + +); eval-when + + +(define-generic-arith-routine (+ 10) + (move res x) + (inst add res y) + (inst jmp :no OKAY) + (inst rcr res 1) ; carry has correct sign + (inst sar res 1) ; remove type bits + + (move ecx res) + + (with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-type)) + + + OKAY) + + +(define-generic-arith-routine (- 10) + ;;; I can't figure out the flags on subtract. Overflow never gets + ;;; set and carry always does. (- 0 most-negative-fixnum) can't be + ;;; easily detected so just let the upper level stuff do it. + (inst jmp DO-STATIC-FUN) + + (move res x) + (inst sub res y) + (inst jmp :no OKAY) + (inst rcr res 1) + (inst sar res 1) ; remove type bits + + (move ecx res) + + (with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-type)) + OKAY) + +(define-generic-arith-routine (* 30) + (move eax x) ; must use eax for 64-bit result + (inst sar eax 2) ; remove *4 fixnum bias + (inst imul y) ; result in edx:eax + (inst jmp :no okay) ; still fixnum + + ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above + ;; pfw says that loses big -- edx is target for arg x and result res + ;; note that 'edx' is not defined -- using x + (inst shrd eax x 2) ; high bits from edx + (inst sar x 2) ; now shift edx too + + (move ecx x) ; save high bits from cdq + (inst cdq) ; edx:eax <- sign-extend of eax + (inst cmp x ecx) + (inst jmp :e SINGLE-WORD-BIGNUM) + + (with-fixed-allocation (res ebx bignum-type (+ bignum-digits-offset 2)) + (storew eax res bignum-digits-offset other-pointer-type) + (storew ecx res (1+ bignum-digits-offset) other-pointer-type)) + (inst jmp DONE) + + SINGLE-WORD-BIGNUM + + (with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset)) + (storew eax res bignum-digits-offset other-pointer-type)) + (inst jmp DONE) + + OKAY + (move res eax) + DONE) + +(define-assembly-routine (generic-negate + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate %negate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:res res (descriptor-reg any-reg) edx-offset) + + (:temp eax dword-reg eax-offset) + (:temp ecx dword-reg ecx-offset)) + (inst test x 3) + (inst jmp :z FIXNUM) + + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) + (inst sub esp-tn (fixnum 3)) ; pw -- was 2 + (inst push eax) + (inst mov ecx (fixnum 1)) ; arg count + + (inst mov eax (make-ea + :dword + :disp (+ nil-value (static-function-offset '%negate)))) + (inst jmp eax) + + FIXNUM + (move res x) + (inst neg res) ; (- most-negative-fixnum) is BIGNUM + (inst jmp :no OKAY) + (inst shr res 2) ; sign bit is data - remove type bits + (move ecx res) + + (with-fixed-allocation (res eax bignum-type (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-type)) + + + OKAY) + + + +;;;; Comparison routines. + +(eval-when (compile eval) + +(defmacro define-cond-assem-rtn (name translate static-fn test) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) + #+nil esi-offset + edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax dword-reg eax-offset) + (:temp ecx dword-reg ecx-offset) + ) + (inst test x 3) + (inst jmp :nz DO-STATIC-FN) + (inst test y 3) + (inst jmp :z DO-COMPARE) + + DO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) + (inst sub esp-tn (fixnum 3)) ; pw -- was 2 + (inst push eax) + (inst mov ecx (fixnum 2)) + (inst mov eax (make-ea + :dword + :disp (+ nil-value (static-function-offset ',static-fn)))) + (inst jmp eax) + + DO-COMPARE + (inst cmp x y) + (inst jmp ,test TRUE) + (inst mov res nil-value) + (inst pop eax) + (inst add eax 2) + (inst jmp eax) + + TRUE + (inst mov res t-value))) + +); eval-when + +(define-cond-assem-rtn generic-< < two-arg-< :l) +(define-cond-assem-rtn generic-> > two-arg-> :g) + +#+pfw-obsolete???? +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) esi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax dword-reg eax-offset) ; zzz added by jrd + (:temp ecx dword-reg ecx-offset) ; zzz added by jrd + ) + (inst cmp x y) + (inst jmp :e RETURN-T) + (inst test x 3) + (inst jmp :z RETURN-NIL) + (inst test y 3) + (inst jmp :nz DO-STATIC-FN) + + RETURN-NIL + (inst mov res nil-value) + (inst pop eax) + (inst add eax 2) + (inst jmp eax) + + DO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) + (inst sub esp-tn (fixnum 3)) ; pw -- was 2 + (inst push eax) + (inst mov ecx (fixnum 2)) + (inst mov eax (make-ea :dword + :disp (+ nil-value + (static-function-offset 'two-arg-eql)))) + (inst jmp eax) + + RETURN-T + (inst mov res t-value)) + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) + #+nil esi-offset + edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax dword-reg eax-offset) + (:temp ecx dword-reg ecx-offset) + ) + (inst test x 3) ; descriptor? + (inst jmp :nz DO-STATIC-FN) ; yes do it here + (inst test y 3) ; descriptor? + (inst jmp :nz DO-STATIC-FN) + (inst cmp x y) + (inst jmp :e RETURN-T) ; ok + + (inst mov res nil-value) + (inst pop eax) + (inst add eax 2) + (inst jmp eax) + + DO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes)) + (inst sub esp-tn (fixnum 3)) ; pw -- was 2 + (inst push eax) + (inst mov ecx (fixnum 2)) + (inst mov eax (make-ea + :dword + :disp (+ nil-value (static-function-offset 'two-arg-=)))) + (inst jmp eax) + + RETURN-T + (load-symbol res t)) + diff --git a/assembly/x86/array.lisp b/assembly/x86/array.lisp new file mode 100644 index 000000000..121fab90f --- /dev/null +++ b/assembly/x86/array.lisp @@ -0,0 +1,146 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/array.lisp,v 1.1 1997/01/21 00:30:28 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains various array operations that are too expensive +;;; (in space) to do inline. +;;; +;;; Written by William Lott. +;;; +;;; Debugged by Paul F. Werkowski -- Spring 1995. +;;; +(in-package :x86) + + +;;;; Allocation + +(define-assembly-routine (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type unsigned-reg eax-offset) + (:arg length any-reg ebx-offset) + (:arg words any-reg ecx-offset) + (:res result descriptor-reg edx-offset) + + (:temp alloc dword-reg edi-offset)) + #-cgc + (with-allocation (alloc) + (inst lea result (make-ea :byte :base alloc :disp other-pointer-type)) + (inst add alloc + (+ (1- (ash 1 lowtag-bits)) (* vector-data-offset word-bytes))) + (inst add alloc words) + (inst and alloc (lognot vm:lowtag-mask))) + #+cgc + (progn + (inst mov alloc (+ (1- (ash 1 lowtag-bits)) + (* vector-data-offset word-bytes))) + (inst add alloc words) + (inst and alloc (lognot vm:lowtag-mask)) + (with-cgc-allocation(alloc alloc) + (inst lea result (make-ea :byte :base alloc :disp other-pointer-type)))) + (storew type result 0 other-pointer-type) + (storew length result vector-length-slot other-pointer-type) + (inst ret)) + + + +;;;; Hash primitives + +(define-assembly-routine (sxhash-simple-string + (:translate %sxhash-simple-string) + (:policy :fast-safe) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg ebx-offset) + (:res result any-reg edx-offset) + + (:temp length any-reg edi-offset) + (:temp esi dword-reg esi-offset) + (:temp ecx dword-reg ecx-offset) + (:temp eax dword-reg eax-offset)) + (declare (ignore result esi ecx eax)) + (loadw length string vector-length-slot other-pointer-type) + ;; zzzzz this appears to be busted + ;; (inst jmp nil (make-fixup 'sxhash-simple-substring :assembly-routine)) + ;; just fall through??? + ) + +(define-assembly-routine (sxhash-simple-substring + (:translate %sxhash-simple-substring) + (:policy :fast-safe) + (:arg-types * positive-fixnum) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg ebx-offset) + (:arg length any-reg edi-offset) + (:res result any-reg edx-offset) + + (:temp esi dword-reg esi-offset) + (:temp ecx dword-reg ecx-offset) + (:temp eax dword-reg eax-offset)) + ;; Compute a pointer to where we are going to be extracting the bits. + (inst lea esi + (make-ea :byte :base string + :disp (- (* vector-data-offset word-bytes) + other-pointer-type))) + ;; Initialize the result. + (inst mov result 0) + ;; Get the count. If it's zero, blow out. + (inst mov ecx length) + (inst jecxz done) + ;; Convert it into count of the number of full words. If zero, then skip + ;; to the part that handles the tail. + (inst shr ecx 4) + (inst jecxz do-extra) + ;; Clear the direction flag, so we advance through memory. + (inst cld) + + LOOP + ;; Merge each successive word with the result. + ;; ZZZZZ undef inst??? + (inst lods eax) ; load 32-bits into eax and (+4 esi) + + (inst rol result 5) + (inst xor result eax) + (inst loop loop) + + DO-EXTRA + ;; Now we have to take care of any bytes that don't make up a full word. + ;; First, check to see how many of them there are. If zero, blow out of + ;; here. Otherwise, multiply by 8. + (inst mov ecx length) + (inst and ecx (fixnum 3)) + (inst jecxz done) + (inst shl ecx 1) + + ;; Grab the last word. + ;; ZZZZZ undef isnt? + (inst lods eax) + + ;; Convert the count into a mask. The count is multiplied by 8, so we just + ;; shift -1 left, which shifts count*8 zeros into the low order end. We + ;; then invert that, ending up with a mask of count*8 ones. + (inst mov esi -1) + (inst shl esi :cl) + (inst not esi) + ;; Use the mask to strip off the bits we arn't interested in, and merge + ;; the remaining bits with the result. + (inst and eax esi) + (inst rol result 5) + (inst xor result eax) + + DONE + + ;; Force result to be a positive fixnum. + (inst and result #x7ffffffc) + (inst ret)) diff --git a/assembly/x86/assem-rtns.lisp b/assembly/x86/assem-rtns.lisp new file mode 100644 index 000000000..648422106 --- /dev/null +++ b/assembly/x86/assem-rtns.lisp @@ -0,0 +1,290 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.1 1997/01/21 00:30:28 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the machine specific support routines needed by +;;; the file assembler. +;;; +;;; Written by William Lott +;;; +;;; Debugged by Paul F. Werkowski -- Spring/Summer 1995. +;;; +(in-package :x86) + + +;;;; Return-multiple + +;;; For return-multiple, we have to move the results from the end of the +;;; frame for the function that is returning to the end of the frame for +;;; the function being returned to. + +#+assembler ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple (:return-style :none)) + (;; These four are really arguments. + (:temp eax dword-reg eax-offset) + (:temp ebx dword-reg ebx-offset) + (:temp ecx dword-reg ecx-offset) + (:temp esi dword-reg esi-offset) + + ;; These we need as temporaries. + (:temp edx dword-reg edx-offset) + (:temp edi dword-reg edi-offset)) + + ;; Pick off the cases where everything fits in register args. + (inst jecxz zero-values) + (inst cmp ecx (fixnum 1)) + (inst jmp :e one-value) + (inst cmp ecx (fixnum 2)) + (inst jmp :e two-values) + (inst cmp ecx (fixnum 3)) + (inst jmp :e three-values) + + ;; Save the count, because the loop is going to destroy it. + (inst mov edx ecx) + + ;; Blit the values down the stack. Note: there might be overlap, so we have + ;; to be careful not to clobber values before we've read them. Because the + ;; stack builds down, we are coping to a larger address. Therefore, we need + ;; to iterate from larger addresses to smaller addresses. + ;; pfw-this says copy ecx words from esi to edi counting down. + (inst shr ecx 2) ; fixnum to raw word count + (inst std) ; count down + (inst sub esi 4) ; ? + (inst lea edi (make-ea :dword :base ebx :disp (- word-bytes))) + (inst rep) + (inst movs :dword) + + ;; Restore the count. + (inst mov ecx edx) + + ;; Set the stack top to the last result. + (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes)) + + ;; Load the register args. + (loadw edx ebx -1) + (loadw edi ebx -2) + (loadw esi ebx -3) + + ;; And back we go. + (inst jmp eax) + + ;; Handle the register arg cases. + ZERO-VALUES + (move esp-tn ebx) + (inst mov edx nil-value) + (inst mov edi edx) + (inst mov esi edx) + (inst jmp eax) + + ONE-VALUE ; Note: we can get this, because the return-multiple vop + ; doesn't check for this case when size > speed. + (loadw edx esi -1) + (inst mov esp-tn ebx) + (inst add eax 2) + (inst jmp eax) + + TWO-VALUES + (loadw edx esi -1) + (loadw edi esi -2) + (inst mov esi nil-value) + (inst lea esp-tn (make-ea :dword :base ebx :disp (* -2 word-bytes))) + (inst jmp eax) + + THREE-VALUES + (loadw edx esi -1) + (loadw edi esi -2) + (loadw esi esi -3) + (inst lea esp-tn (make-ea :dword :base ebx :disp (* -3 word-bytes))) + (inst jmp eax)) + + + +;;;; tail-call-variable. + +;;; For tail-call-variable, we have to copy the arguments from the end of our +;;; stack frame (were args are produced) to the start of our stack frame +;;; (were args are expected). +;;; +;;; We take the function to call in EAX and a pointer to the arguments in +;;; ESI. EBP says the same over the jump, and the old frame pointer is +;;; still saved in the first stack slot. The return-pc is saved in +;;; the second stack slot, so we have to push it to make it look like +;;; we actually called. We also have to compute ECX from the difference +;;; between ESI and the stack top. +;;; +#+assembler ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ((:temp eax dword-reg eax-offset) + (:temp ebx dword-reg ebx-offset) + (:temp ecx dword-reg ecx-offset) + (:temp edx dword-reg edx-offset) + (:temp edi dword-reg edi-offset) + (:temp esi dword-reg esi-offset)) + + ;; Calculate NARGS (as a fixnum) + (move ecx esi) + (inst sub ecx esp-tn) + + ;; Check for all the args fitting the the registers. + (inst cmp ecx (fixnum 3)) + (inst jmp :le REGISTER-ARGS) + + ;; Save the OLD-FP and RETURN-PC because the blit it going to trash + ;; those stack locations. Save the ECX, because the loop is going + ;; to trash it. + (pushw ebp-tn -1) + (loadw ebx ebp-tn -2) + (inst push ecx) + + ;; Do the blit. Because we are coping from smaller addresses to larger + ;; addresses, we have to start at the largest pair and work our way down. + (inst shr ecx 2) ; fixnum to raw words + (inst std) ; count down + (inst lea edi (make-ea :dword :base ebp-tn :disp (- word-bytes))) + (inst sub esi (fixnum 1)) + (inst rep) + (inst movs :dword) + + ;; Load the register arguments carefully. + (loadw edx ebp-tn -1) + + ;; Restore OLD-FP and ECX. + (inst pop ecx) + (popw ebp-tn -1) ; overwrites a0 + + ;; Blow off the stack above the arguments. + (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes)) + + ;; remaining register args + (loadw edi ebp-tn -2) + (loadw esi ebp-tn -3) + + ;; Push the (saved) return-pc so it looks like we just called. + (inst push ebx) + + ;; And jump into the function. + (inst jmp + (make-ea :byte :base eax + :disp (- (* closure-function-slot word-bytes) + function-pointer-type))) + + ;; All the arguments fit in registers, so load them. + REGISTER-ARGS + (loadw edx esi -1) + (loadw edi esi -2) + (loadw esi esi -3) + + ;; Clear most of the stack. + (inst lea esp-tn + (make-ea :dword :base ebp-tn :disp (* -3 word-bytes))) + + ;; Push the return-pc so it looks like we just called. + (pushw ebp-tn -2) + + ;; And away we go. +; (inst jmp-indirect +; (make-ea :byte :base eax :disp (- (* closure-function-slot word-bytes) +; function-pointer-type))) + ;; -- jrd + (inst jmp + (make-ea :byte :base eax :disp (- (* closure-function-slot word-bytes) + function-pointer-type))) + ) + + + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target (descriptor-reg any-reg) edx-offset) + (:arg start any-reg ebx-offset) + (:arg count any-reg ecx-offset) + (:temp catch any-reg eax-offset)) + + (declare (ignore start count)) + + (load-symbol-value catch lisp::*current-catch-block*) + + LOOP + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst or catch catch) ; check for NULL pointer + (inst jmp :z error)) + + (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) + (inst jmp :e exit) + + (loadw catch catch catch-block-previous-catch-slot) + (inst jmp loop) + + EXIT + + + ;; hear eax points to catch block containing symbol pointed to by edx + ;; (inst jmp-near (make-fixup 'unwind :assembly-routine)) -- jrd + ;; + ;; fall into unwind + ) + +;;;; Non-local exit noise. + +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset) + (:temp uwp dword-reg esi-offset)) + (declare (ignore count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst or block block) ; check for NULL pointer + (inst jmp :z error)) + + (load-symbol-value uwp lisp::*current-unwind-protect-block*) + + (inst;; does *cuwpb* match value stored in argument cuwp slot? + cmp uwp (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) + ;; If a match, return to context in arg block. + (inst jmp :e do-exit) + + ;; Not a match - return to *current-unwind-protect-block* context. + ;; Important! Must save (and return) the arg 'block' for later use!! + (move edx-tn block) + (move block uwp) + ;; Set next unwind protect context. + (loadw uwp uwp unwind-block-current-uwp-slot) + (store-symbol-value uwp lisp::*current-unwind-protect-block*) + + DO-EXIT + + (loadw ebp-tn block unwind-block-current-cont-slot) + + ;; apparently a carefully held secret is that uwp-entry expects + ;; some things in known locations so that they can be saved on + ;; the stack! Jeesh! + + ;;(move edx-tn block) ; gets shoved into 'block' + ;;(move ecx-tn count) ; a noop + + ;; This seems needed to properly save the 'start' value so that the + ;; correct thing gets passed into the various nlx entry points although + ;; I think the compiler really ought to do it. + + (storew start ebp-tn (- (1+ old-fp-save-offset))) + + (inst jmp (make-ea :byte :base block + :disp (* unwind-block-entry-pc-slot word-bytes)))) diff --git a/assembly/x86/bit-bash.lisp b/assembly/x86/bit-bash.lisp new file mode 100644 index 000000000..6417cbcf0 --- /dev/null +++ b/assembly/x86/bit-bash.lisp @@ -0,0 +1 @@ +;; Just a dummy file to keep loadbackend happy. diff --git a/assembly/x86/kludges.lisp b/assembly/x86/kludges.lisp new file mode 100644 index 000000000..ecd4c3487 --- /dev/null +++ b/assembly/x86/kludges.lisp @@ -0,0 +1,66 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/Attic/kludges.lisp,v 1.1 1997/01/21 00:30:28 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Kludges to make up for the fact that we don't have an assembler. +;;; replace this file with real native assembly source later. +;;; +;;; by jrd +;;; + +(in-package :x86) + + +#+assembler +;;; +;;; a kludge to tranpoline through when we're calling into lisp. +;;; this cf the sparc one +;;; +;;; int call_into_lisp_kludge(control_stack_pointer, function, args, nargs); +;;; +(define-assembly-routine (call-into-lisp-kludge) + ((:temp eax dword-reg eax-offset) + (:temp ebx dword-reg ebx-offset) + (:temp ecx dword-reg ecx-offset) + (:temp edx dword-reg edx-offset) + (:temp esi dword-reg esi-offset) + (:temp edi dword-reg edi-offset) + (:temp esp dword-reg esp-offset) + (:temp ebp dword-reg ebp-offset)) + ;; get the lisp stack pointer into ebx, so we can push things on it + (inst mov ebp (make-ea :dword :base esp :disp 4)) + + ;; make room on the lisp stack + (inst sub ebp 8) + + ;; pull the args off the stack +; (inst mov eax (make-ea :dword :base esp :disp 16)) ;nargs. zzz is this right? +; (inst mov (make-ea :dword :base ebp :disp 4) eax) +; (inst mov eax (make-ea :dword :base esp :disp 12)) ; args +; (inst mov (make-ea :dword :base ebp :disp 0) eax) + + ;; get the function + (inst mov eax (make-ea :dword :base esp :disp 8)) + (inst add eax 23) ; function-code-offset + (inst mov edi eax) ; move it to reg-code + + ;; clear the descriptor regs + (inst mov eax 0) + (inst mov ebx 0) + (inst mov ecx 0) + (inst mov edx 0) + + ;; zzz what else? + + ;; jump there + (inst call edi)) + diff --git a/assembly/x86/support.lisp b/assembly/x86/support.lisp new file mode 100644 index 000000000..1a9dfa81f --- /dev/null +++ b/assembly/x86/support.lisp @@ -0,0 +1,62 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/support.lisp,v 1.1 1997/01/21 00:30:28 ram Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the machine specific support routines needed by +;;; the file assembler. +;;; +;;; Written by William Lott. +;;; +(in-package :x86) + +(def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + (:raw + (values + `((inst call (make-fixup ',name :assembly-routine))) + nil)) + (:full-call + (values + #-x86-lra + `((note-this-location ,vop :call-site) + (inst call (make-fixup ',name :assembly-routine)) + (note-this-location ,vop :single-value-return) + (move esp-tn ebx-tn)) + #+x86-lra + `((note-this-location ,vop :call-site) + (inst push (make-fixup nil :code-object return)) + (inst jmp (make-fixup ',name :assembly-routine)) + (align lowtag-bits #x90) + (inst lra-header-word) + (inst nop) + (inst nop) + (inst nop) + RETURN + (note-this-location ,vop :single-value-return) + (move esp-tn ebx-tn)) + '((:save-p :compute-only)))) + (:none + (values + `((inst jmp (make-fixup ',name :assembly-routine))) + nil)))) + +(def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `(inst ret)) + (:full-call + `( + (inst pop eax-tn) + + (inst add eax-tn 2) + (inst jmp eax-tn))) + (:none))) diff --git a/lisp/Config.FreeBSD b/lisp/Config.FreeBSD new file mode 100644 index 000000000..ff9faf4eb --- /dev/null +++ b/lisp/Config.FreeBSD @@ -0,0 +1,19 @@ +PATH1=../../../p86/lisp +PATH2=../../../17f/lisp +vpath %.h $(PATH1):$(PATH2) +vpath %.c $(PATH1):$(PATH2) +vpath %.S $(PATH1) +CPPFLAGS = -I. -I$(PATH1) -I$(PATH2) -I- -I/usr/X11R6/include +CC = gcc # -Wall -Wstrict-prototypes -Wmissing-prototypes +LD = ld +CPP = cpp +CFLAGS = -m486 -g -DWANT_CGC -O2 +ASFLAGS = -g +NM = nm -gp +UNDEFSYMPATTERN=-Xlinker -u -Xlinker & +ASSEM_SRC = x86-assem.S +ARCH_SRC = x86-arch.c +OS_SRC = FreeBSD-os.c os-common.c +OS_LINK_FLAGS=-static +OS_LIBS= -lgnumalloc +GC_SRC= cgc.c diff --git a/lisp/Config.linux b/lisp/Config.linux new file mode 100644 index 000000000..2dee6f5bc --- /dev/null +++ b/lisp/Config.linux @@ -0,0 +1,20 @@ +PATH1=../../p86/lisp +PATH2=../../17f/lisp +vpath %.h $(PATH1):$(PATH2) +vpath %.c $(PATH1):$(PATH2) +vpath %.S $(PATH1) +CPPFLAGS = -I. -I$(PATH1) -I$(PATH2) -I- -I/usr/X11R6/include +CC = gcc -Wstrict-prototypes -O2 -fno-strength-reduce # -Wall +LD = ld +CPP = cpp +CFLAGS = -m486 -g -DWANT_CGC -O2 +ASFLAGS = -g +NM = nm -p +UNDEFSYMPATTERN=-Xlinker -u -Xlinker & +ASSEM_SRC = x86-assem.S linux-stubs.S +ARCH_SRC = x86-arch.c +OS_SRC = Linux-os.c os-common.c +OS_LINK_FLAGS= +#-static +OS_LIBS= -lieee -lm -ldl +GC_SRC= cgc.c diff --git a/lisp/FreeBSD-os.c b/lisp/FreeBSD-os.c new file mode 100644 index 000000000..d87618a67 --- /dev/null +++ b/lisp/FreeBSD-os.c @@ -0,0 +1,259 @@ +/* + * FreeBSD-os.c. Maybe could be just BSD-os.c + * From osf1-os.c,v 1.1 94/03/27 15:30:51 hallgren Exp $ + * + * OS-dependent routines. This file (along with os.h) exports an + * OS-independent interface to the operating system VM facilities. + * Suprisingly, this interface looks a lot like the Mach interface + * (but simpler in some places). For some operating systems, a subset + * of these functions will have to be emulated. + * + * This is the OSF1 version. By Sean Hallgren. + * Much hacked by Paul Werkowski + * + */ + +#include <stdio.h> +#include <unistd.h> +#include <sys/types.h> +#include <sys/param.h> +#include <signal.h> +#include <sys/user.h> +#include <sys/ptrace.h> +#include <sys/wait.h> +#include <sys/param.h> +#include <sys/file.h> +#include <sys/proc.h> +#include <errno.h> +#include "./signal.h" +#include "os.h" +#include "arch.h" +#include "globals.h" +#include "interrupt.h" +#include "lispregs.h" +#include "internals.h" + +#include "x86-validate.h" +vm_size_t os_vm_page_size; +#define DPRINTF(t,a) {if(t)fprintf a;} + +#define HAVE_SIGVEC /* defined - now obsolete */ +#define HAVE_SIGACTION /* replacement for SIGVEC */ +/* SIGSTKSZ == 40Kb */ +#define SIG_STACK_SIZE (SIGSTKSZ/sizeof(double)) +/* make sure the stack is 8 byte aligned */ +#if defined USE_SIG_STACK +static double estack_buf[SIG_STACK_SIZE]; +#endif + +void +os_init() +{ + +#if defined USE_SIG_STACK + static struct sigaltstack estack; + estack.ss_base = (char*)estack_buf; /* this should be ss_sp */ + estack.ss_size = SIGSTKSZ; + estack.ss_flags = 0; + if (sigaltstack(&estack, 0) < 0) + perror("sigaltstack"); +#endif + os_vm_page_size=OS_VM_DEFAULT_PAGESIZE; +} + +int +sc_reg(struct sigcontext *c, int offset) +{ + switch(offset) + { + case 0: return c->sc_eax; + case 2: return c->sc_ecx; + case 4: return c->sc_edx; + case 6: return c->sc_ebx; + case 8: return c->sc_esp; + case 10: return c->sc_ebp; + case 12: return c->sc_esi; + case 14: return c->sc_edi; + } + return 0; +} +void +os_save_context() +{ + /* Called from interrupt handlers so C stuff knows things set in Lisp + */ +} +void +os_set_context() +{ +} + +os_vm_address_t +os_validate(os_vm_address_t addr, os_vm_size_t len) +{ + int flags = MAP_PRIVATE|MAP_ANONYMOUS; + + if(addr) flags|=MAP_FIXED; + else flags|=MAP_VARIABLE; + + DPRINTF(0,(stderr,"os_validate %x %d => ",addr,len)); + if((addr=mmap(addr,len,OS_VM_PROT_ALL,flags,-1,0)) == (os_vm_address_t) -1) + { + perror("mmap"); + return NULL; + } + DPRINTF(0,(stderr,"%x\n",addr)); + + return addr; +} + +void +os_invalidate(os_vm_address_t addr, os_vm_size_t len) +{ + DPRINTF(0,(stderr,"os_invalidate %x %d\n",addr,len)); + if(munmap(addr,len) == -1) + perror("munmap"); +} + +os_vm_address_t +os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len) +{ + if((addr=mmap(addr,len,OS_VM_PROT_ALL,MAP_PRIVATE|MAP_FILE|MAP_FIXED,fd, + (off_t) offset)) == (os_vm_address_t) -1) + perror("mmap"); + + return addr; +} + +void +os_flush_icache(os_vm_address_t address, os_vm_size_t length) +{ +} + +void +os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot) +{ + if(mprotect(address, length, prot) == -1) + perror("mprotect"); +} + +static boolean +in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen) +{ + char* beg = (char*)sbeg; + char* end = (char*)sbeg + slen; + char* adr = (char*)a; + return (adr >= beg && adr < end); +} +boolean +valid_addr(os_vm_address_t addr) +{ + int ret; + os_vm_address_t newaddr; + newaddr=os_trunc_to_page(addr); + + if( in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) + || in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE ) + || in_range_p(addr, DYNAMIC_0_SPACE_START, DYNAMIC_SPACE_SIZE ) + || in_range_p(addr, DYNAMIC_1_SPACE_START, DYNAMIC_SPACE_SIZE ) + || in_range_p(addr, CONTROL_STACK_START , CONTROL_STACK_SIZE ) + || in_range_p(addr, BINDING_STACK_START , BINDING_STACK_SIZE )) + return TRUE; + return FALSE; +} + + +static void +sigbus_handler(int signal, int code, struct sigcontext *context) +{ + DPRINTF(0,(stderr,"sigbus:\n")); +#if defined NOTYET + if(!interrupt_maybe_gc(signal, code, context)) +#endif + interrupt_handle_now(signal, code, context); +} +static void +sigsegv_handler(int signal, int code, struct sigcontext *context) +{ + DPRINTF(0,(stderr,"os_sigsegv\n")); +#if defined NOTYET + if(!interrupt_maybe_gc(signal, code, context)) +#endif + interrupt_handle_now(signal, code, context); +} + +void +os_install_interrupt_handlers(void) +{ + interrupt_install_low_level_handler(SIGSEGV,sigsegv_handler); + interrupt_install_low_level_handler(SIGBUS,sigbus_handler); +} + + +/* All this is needed to get the floating-point status register + * that was stuffed in process context on a SIGFPE. We need it + * to determine what kind of condition occured. This code also + * sets up the possibility of defining some local structs to + * make up for lack of sigcontext registers and have a low level + * SIGFPE handler dummy something up. + */ +#ifdef not_now_maybe_not_ever +struct user u; +unsigned int +BSD_get_fp_modes() +{ + /* All this is highly dependent on FreeBSD internals. Watch Out! */ + /* offset to where NPX state is saved in a process */ + unsigned int fpoff = (char*)&u.u_pcb.pcb_savefpu - (char*)&u; + unsigned int fplen = sizeof u.u_pcb.pcb_savefpu / sizeof(int); + /* offset to the last exception status word */ + unsigned int swoff = (char*)&u.u_pcb.pcb_savefpu.sv_ex_sw - (char*)&u; + pid_t pid; + /* fork to capture NPX state in another process */ + pid = fork(); + if(pid) + { + u_long ex_sw, ex_cw; + int status; + printf("p: wait1\n"); fflush(stdout); + wait4(pid, &status, WUNTRACED, NULL); + printf("P: wait over\n"); fflush(stdout); + ex_sw = ptrace(PT_READ_U, pid, (caddr_t)swoff, 0); + if(ex_sw == -1) + perror("ptrace"); + { + /* Might as well get the rest of the saved state. */ + int i, *ip = (int*)&u.u_pcb.pcb_savefpu; + unsigned int*uaddr = (unsigned int*)fpoff; + for(i=0; i<fplen; i++, uaddr++) + *ip++ = ptrace(PT_READ_U, pid, (caddr_t)uaddr, 0); + ex_cw = u.u_pcb.pcb_savefpu.sv_env.en_cw & 0xffff; + } + printf("sw %x cw %x\n",ex_sw,ex_cw); fflush(stdout); + printf("p: Kill\n"); fflush(stdout); + ptrace(PT_CONTINUE, pid, NULL, 0); + printf("p: wait2\n"); fflush(stdout); + wait4(pid, &status, 0, NULL); + printf("p: wait over\n"); fflush(stdout); + ex_sw &= 0xffff; + ex_cw &= 0xffff; + ex_cw ^= 0x3f; + return (ex_sw << 16) | ex_cw ; + } + else + { + /* As child, notify OS to allow ptrace calls */ + int status = ptrace(PT_TRACE_ME, getpid(), NULL, 0); + if(status == -1) + perror("kid"); + printf("c:\n"); fflush(stdout); + /* Go idle so parent can poke at process contents. */ + raise(SIGSTOP); + printf("c: stopped?\n"); + while(0) + { sigsuspend(0); printf("c:\n"); fflush(stdout); } + exit(1); + } +} +#endif + diff --git a/lisp/FreeBSD-os.h b/lisp/FreeBSD-os.h new file mode 100644 index 000000000..c626049a1 --- /dev/null +++ b/lisp/FreeBSD-os.h @@ -0,0 +1,41 @@ +/* + + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/FreeBSD-os.h,v 1.1 1997/01/21 00:28:13 ram Exp $ + + This code was written as part of the CMU Common Lisp project at + Carnegie Mellon University, and has been placed in the public domain. + +*/ + +#include <sys/types.h> +#include <sys/mman.h> +#include <sys/signal.h> + +#define MAP_ANONYMOUS MAP_ANON +#define MAP_VARIABLE 0 +#define PRINTNOISE +#undef PRINTNOISE +/* #define DEBUG_SCAVENGE_VERBOSE */ +typedef caddr_t os_vm_address_t; +typedef vm_size_t os_vm_size_t; +typedef off_t os_vm_offset_t; +typedef int os_vm_prot_t; + +#define OS_VM_PROT_READ PROT_READ +#define OS_VM_PROT_WRITE PROT_WRITE +#define OS_VM_PROT_EXECUTE PROT_EXEC + +#define OS_VM_DEFAULT_PAGESIZE 4096 + +int +sc_reg(struct sigcontext*,int); +void +os_save_context(); +#define SAVE_CONTEXT os_save_context + +#define USE_SIG_STACK +/* + * On second thought, a separate stack would probably + * confuse the hell out of the Lisp debugger! + */ +#undef USE_SIG_STACK diff --git a/lisp/GNUmakefile b/lisp/GNUmakefile index 210b11748..642f6d05d 100644 --- a/lisp/GNUmakefile +++ b/lisp/GNUmakefile @@ -1,18 +1,22 @@ -# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.11 1995/02/17 00:51:01 wlott Exp $ +# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.12 1997/01/21 00:28:13 ram Exp $ all: lisp.nm CC = gcc + DEPEND_FLAGS = include Config +ifndef GC_SRC +GC_SRC = gc.c +endif + SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c \ - vars.c parse.c interrupt.c search.c validate.c gc.c globals.c \ + vars.c parse.c interrupt.c search.c validate.c globals.c \ dynbind.c breakpoint.c regnames.c backtrace.c save.c purify.c \ socket.c runprog.c time.c undefineds.c \ - ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} - + ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC} OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(patsubst %.s,%.o,$(SRCS)))) @@ -21,7 +25,7 @@ OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(patsubst %.s,%.o,$(SRCS)))) lisp.nm: lisp echo 'Map file for lisp version ' `cat version` > ,lisp.nm - $(NM) lisp >> ,lisp.nm + $(NM) lisp | grep -v " F \| U " >> ,lisp.nm mv ,lisp.nm lisp.nm lisp: version.c ${OBJS} version diff --git a/lisp/Linux-os.c b/lisp/Linux-os.c new file mode 100644 index 000000000..21b958906 --- /dev/null +++ b/lisp/Linux-os.c @@ -0,0 +1,274 @@ +/* + * Linux-os.c. + * Form FreeBSD-os.c + * From osf1-os.c,v 1.1 94/03/27 15:30:51 hallgren Exp $ + * + * OS-dependent routines. This file (along with os.h) exports an + * OS-independent interface to the operating system VM facilities. + * Suprisingly, this interface looks a lot like the Mach interface + * (but simpler in some places). For some operating systems, a subset + * of these functions will have to be emulated. + * + * This is the OSF1 version. By Sean Hallgren. + * Much hacked by Paul Werkowski + * Morfed from the FreeBSD file by Peter Van Eynde (July 1996) + * + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.c,v 1.1 1997/01/21 00:28:13 ram Exp $ + * + */ + +#include <stdio.h> +#include <sys/param.h> +#include <sys/file.h> +#include <errno.h> +#include "./signal.h" +#include "os.h" +#include "arch.h" +#include "globals.h" +#include "interrupt.h" +#include "lispregs.h" +#include "internals.h" +#include <sys/socket.h> +#include <sys/utsname.h> + +#include <sys/types.h> +#include <signal.h> +/* #include <sys/sysinfo.h> */ +#include <sys/time.h> +#include <sys/stat.h> +#include <unistd.h> + +#include "x86-validate.h" +size_t os_vm_page_size; + +#define DPRINTF(t,a) {if(t)fprintf a;} + +#undef HAVE_SIGVEC /* defined - now obsolete */ +#undef HAVE_SIGACTION /* replacement for SIGVEC */ +/* SIGSTKSZ == 40Kb */ +#define SIG_STACK_SIZE (SIGSTKSZ/sizeof(double)) +/* make sure the stack is 8 byte aligned */ +#if defined USE_SIG_STACK +static double estack_buf[SIG_STACK_SIZE]; +#endif + + +void +os_init(void) +{ + struct utsname name; + + uname(&name); + +/* we need this for mmap */ + + if ((name.release[0]) < '2') + { + printf("Linux version must be later then 2.0.0!\n"); + exit(2); + } + +#if defined USE_SIG_STACK + static struct sigaltstack estack; + estack.ss_base = (char*)estack_buf; /* this should be ss_sp */ + estack.ss_size = SIGSTKSZ; + estack.ss_flags = 0; + if (sigaltstack(&estack, 0) < 0) + perror("sigaltstack"); +#endif +#if 0 + os_vm_page_size=OS_VM_DEFAULT_PAGESIZE; +#else + os_vm_page_size=getpagesize(); +#endif +__setfpucw(0x1372|4|8|16|32); /*no interrupts */ +} + +int +sc_reg(struct sigcontext_struct *c, int offset) +{ + switch(offset) + { + case 0: return c->eax; + case 2: return c->ecx; + case 4: return c->edx; + case 6: return c->ebx; + case 8: return c->esp; + case 10: return c->ebp; + case 12: return c->esi; + case 14: return c->edi; + } + return 0; +} + +void +os_save_context(void) +{ + /* Called from interrupt handlers so C stuff knows things set in Lisp + */ +} + +void +os_set_context(void) +{ +} + +int do_mmap(os_vm_address_t *addr, os_vm_size_t len, + int flags) +{ + /* we _must_ have the memory where we want it...*/ + os_vm_address_t old_addr=*addr; + + *addr=mmap(*addr,len,OS_VM_PROT_ALL,flags,-1,0); + if (((old_addr != NULL) && (*addr != old_addr)) || + (*addr == (os_vm_address_t) -1)) + { + fprintf(stderr, "Error in allocating memory, do you have more then 16MB of memory+swap?\n"); + perror("mmap"); + return 1; + } + return 0; +} + +os_vm_address_t +os_validate(os_vm_address_t addr, os_vm_size_t len) +{ + int flags = MAP_PRIVATE|MAP_ANONYMOUS; + int oa=addr,olen=len; + + if(addr) flags|=MAP_FIXED; + else flags|=MAP_VARIABLE; + + DPRINTF(0,(stderr,"os_validate %x %d => ",addr,len)); + if (addr) + { + do { + if (len <= 0x1000000 ) + { + if (do_mmap(&addr,len,flags)) + return NULL; + len=0; + } + else + { + len = len-0x1000000; + if (do_mmap(&addr,0x1000000,flags)) + return NULL; + addr+=0x1000000; + } + } + while (len>0); + } + else + { + if(do_mmap(&addr,len,flags)) + return NULL; + return addr; + } + DPRINTF(0,(stderr,"%x\n",addr)); + return oa; +} + +void +os_invalidate(os_vm_address_t addr, os_vm_size_t len) +{ + DPRINTF(0,(stderr,"os_invalidate %x %d\n",addr,len)); + if(munmap(addr,len) == -1) + perror("munmap"); +} + +os_vm_address_t +os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len) +{ + if((addr=mmap(addr,len,OS_VM_PROT_ALL,MAP_PRIVATE|MAP_FILE|MAP_FIXED,fd, + (off_t) offset)) == (os_vm_address_t) -1) + perror("mmap"); + + return addr; +} + +void +os_flush_icache(os_vm_address_t address, os_vm_size_t length) +{ +} + +void +os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot) +{ + if(mprotect(address, length, prot) == -1) + perror("mprotect"); +} + +static boolean +in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen) +{ + char* beg = (char*)sbeg; + char* end = (char*)sbeg + slen; + char* adr = (char*)a; + return (adr >= beg && adr < end); +} +boolean +valid_addr(os_vm_address_t addr) +{ + int ret; + os_vm_address_t newaddr; + newaddr=os_trunc_to_page(addr); + + if( in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) + || in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE ) + || in_range_p(addr, DYNAMIC_0_SPACE_START, DYNAMIC_SPACE_SIZE ) + || in_range_p(addr, DYNAMIC_1_SPACE_START, DYNAMIC_SPACE_SIZE ) + || in_range_p(addr, CONTROL_STACK_START , CONTROL_STACK_SIZE ) + || in_range_p(addr, BINDING_STACK_START , BINDING_STACK_SIZE )) + return TRUE; + return FALSE; +} + + +static void +sigbus_handler(HANDLER_ARGS) +{ + GET_CONTEXT + + DPRINTF(1,(stderr,"sigbus:\n")); /* there is no sigbus in linux??? */ +#if defined NOTYET + if(!interrupt_maybe_gc(signal, code, context)) +#endif + interrupt_handle_now(signal,contextstruct); +} +static void +sigsegv_handler(HANDLER_ARGS) +{ + GET_CONTEXT + + DPRINTF(0,(stderr,"os_sigsegv\n")); +#if defined NOTYET + if(!interrupt_maybe_gc(signal, code, context)) +#endif + interrupt_handle_now(signal,contextstruct); +} + +void +os_install_interrupt_handlers(void) +{ + interrupt_install_low_level_handler(SIGSEGV,sigsegv_handler); + interrupt_install_low_level_handler(SIGBUS,sigbus_handler); +} + +#if 0 +/* functions that disapear ! */ +#define Force_Fct(fct) int * Force_ ## fct (void) {return &fct;} + +Force_Fct(select) +Force_Fct(stat) +Force_Fct(lstat) +Force_Fct(fstat) +Force_Fct(socket) +Force_Fct(connect) +Force_Fct(listen) +Force_Fct(recv) +Force_Fct(accept) +Force_Fct(bind) +#endif + + diff --git a/lisp/Linux-os.h b/lisp/Linux-os.h new file mode 100644 index 000000000..6a6ad9ebd --- /dev/null +++ b/lisp/Linux-os.h @@ -0,0 +1,76 @@ +/* + + This code was written as part of the CMU Common Lisp project at + Carnegie Mellon University, and has been placed in the public domain. + + Morfed from the FreeBSD file by Peter Van Eynde (July 1996) +*/ + +#include <stdlib.h> +#include <sys/types.h> +#include <sys/mman.h> +#include <sys/signal.h> +#include <asm/sigcontext.h> +#include <string.h> +#include <dlfcn.h> +#include <sys/time.h> +#include <sys/stat.h> +#include <unistd.h> +#include <sys/syscall.h> +#include <asm/unistd.h> +#include <errno.h> +#define MAP_VARIABLE 0 +#define PRINTNOISE +/* #define DEBUG_SCAVENGE_VERBOSE */ + +typedef caddr_t os_vm_address_t; /* like hpux */ +typedef size_t os_vm_size_t; /* like hpux */ +typedef off_t os_vm_offset_t; /* like hpux */ +typedef int os_vm_prot_t; /* like hpux */ + +#define OS_VM_PROT_READ PROT_READ /* like hpux */ +#define OS_VM_PROT_WRITE PROT_WRITE /* like hpux */ +#define OS_VM_PROT_EXECUTE PROT_EXEC /* like hpux */ + +#define OS_VM_DEFAULT_PAGESIZE 4096 /* like hpux */ + +int sc_reg(struct sigcontext_struct *,int); +void os_save_context(void); + +#define SAVE_CONTEXT os_save_context + +typedef struct sigcontext_struct sigcontext; + +#define POSIX_SIGS + +#define HANDLER_ARGS int signal, struct sigcontext_struct contextstruct +#define GET_CONTEXT int code=0; struct sigcontext_struct *context=&contextstruct; + +#define sigvec sigaction +#define sv_mask sa_mask +#define sv_flags sa_flags +#define sv_handler sa_handler +#define sv_onstack sa_mask /* ouch, this one really hurts */ +#define uc_sigmask oldmask +#define sc_pc eip +#define sc_mask oldmask +#define sc_sp esp +#define sigcontext sigcontext_struct +#define sa_sigaction sa_handler +#define SA_SIGINFO 0 + +#define sc_eax eax +#define sc_ecx ecx +#define sc_edx edx +#define sc_ebx ebx +#define sc_esp esp +#define sc_ebp ebp +#define sc_esi esi +#define sc_edi edi + +/* + * On second thought, a separate stack would probably + * confuse the hell out of the Lisp debugger! + */ +#undef USE_SIG_STACK + diff --git a/lisp/WARNING.files b/lisp/WARNING.files new file mode 100644 index 000000000..dae228f53 --- /dev/null +++ b/lisp/WARNING.files @@ -0,0 +1,9 @@ +Three critical files are created in the build directory and +may not be present in this source directory after Genesis. +Look for correct versions of + + internals.h + version + lisp.nm + +before making distributions. diff --git a/lisp/alloc.c b/lisp/alloc.c index 3973b38db..e896a447f 100644 --- a/lisp/alloc.c +++ b/lisp/alloc.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/alloc.c,v 1.2 1994/03/27 15:19:55 hallgren Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/alloc.c,v 1.3 1997/01/21 00:28:13 ram Exp $ */ #include "lisp.h" #include "internals.h" @@ -22,12 +22,14 @@ clear_auto_gc_trigger(); set_auto_gc_trigger(new_value); #endif - +#define ALIGNED_SIZE(n) (n+lowtag_Mask) & ~lowtag_Mask /**************************************************************** Allocation Routines. ****************************************************************/ - +#if defined WANT_CGC +extern lispobj *alloc(int bytes); +#else static lispobj *alloc(int bytes) { lispobj *result; @@ -45,12 +47,13 @@ static lispobj *alloc(int bytes) return result; } +#endif static lispobj *alloc_unboxed(int type, int words) { lispobj *result; - result = alloc((1 + words) * sizeof(lispobj)); + result = alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj))); *result = (lispobj) (words << type_Bits) | type; @@ -61,7 +64,8 @@ static lispobj alloc_vector(int type, int length, int size) { struct vector *result; - result = (struct vector *)alloc((2 + (length*size + 31) / 32) * sizeof(lispobj)); + result = (struct vector *) + alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj))); result->header = type; result->length = make_fixnum(length); @@ -71,7 +75,7 @@ static lispobj alloc_vector(int type, int length, int size) lispobj alloc_cons(lispobj car, lispobj cdr) { - struct cons *ptr = (struct cons *)alloc(sizeof(struct cons)); + struct cons *ptr = (struct cons *)alloc(ALIGNED_SIZE(sizeof(struct cons))); ptr->car = car; ptr->cdr = cdr; diff --git a/lisp/cgc.c b/lisp/cgc.c new file mode 100644 index 000000000..cf9105f7f --- /dev/null +++ b/lisp/cgc.c @@ -0,0 +1,1902 @@ +/* cgc.c -*- Mode: C; comment-column: 40; -*- + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/cgc.c,v 1.1 1997/01/21 00:28:13 ram Exp $ + * + * Conservative Garbage Collector for CMUCL x86. + * + * Copyright (c) Paul F Werkowski, 1996. + * + * There is absolutely NO WARRANTY associated with this code! Use + * at your own risk! If you can't handle the fact that this may + * not work the way you want then just DELETE THIS FILE NOW! + * + * This code is based on software written by William Lott, and + * Public Domain codes from Carnegie Mellon University. + * + * Received from William 27 Jul 95. + * + * Debug, FreeBSD hooks, and integration by Paul Werkowski + * + */ +#include <stdio.h> +#include <assert.h> +#include <signal.h> +#include "os.h" /* for SetSymbolValue */ +#include "x86-validate.h" /* for memory layout */ +#include "x86-lispregs.h" +#include "lisp.h" /* for object defs */ +#include "interrupt.h" /* interrupt_handlers */ +#include "internals.h" +#include "cgc.h" + +#if !defined MIN +#define MIN(a,b)(((a)<(b))?(a):(b)) +#define MAX(a,b)(((a)>(b))?(a):(b)) +#endif + +#include <unistd.h> +#include <stdlib.h> +#if defined unix +#include <sys/param.h> +#endif +#include <sys/types.h> +#include <sys/time.h> +#include <sys/resource.h> + + +#define dprintf(t,exp) if(t){printf exp ; fflush(stdout);} + +/* Object representation details. The allocator/collector knows + * almost nothing about lisp internals and is fairly general. +*/ + +#define ALIGN_BITS 3 +#define ALIGN_BYTES (1<<ALIGN_BITS) +#define ALIGNEDP(addr) ((((int)addr)&(ALIGN_BYTES-1)) == 0) + +/* Type of an object. */ +typedef struct object +{ + long header; + struct object*data[1]; +} *obj_t; + +/* Just leave unused space */ +#define NOTE_EMPTY(ptr,bytes) {} + + +/* Collector datastructures */ + +#define BLOCK_BITS 16 +#define BLOCK_BYTES (1<<BLOCK_BITS) +#define BLOCK_NUMBER(ptr) (((long)(ptr))>>BLOCK_BITS) +#define BLOCK_ADDRESS(num) ((void *)((num)<<BLOCK_BITS)) + +#define CHUNK_BITS 9 +#define CHUNK_BYTES (1<<CHUNK_BITS) +#define CHUNK_NUMBER(ptr) (((long)(ptr))>>CHUNK_BITS) +#define CHUNK_ADDRESS(num) ((void *)((num)<<CHUNK_BITS)) + +#define BLOCK_CHUNKS (1<<(BLOCK_BITS-CHUNK_BITS)) + + +#define ROUNDDOWN(val,x) ((val)&~((x)-1)) +#define ROUNDUP(val,x) ROUNDDOWN((val)+(x)-1,x) + +#define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \ + __FILE__, __LINE__) + +#if 0 +#define gc_assert(ex) {if (!(ex)) gc_abort();} +#else +#define gc_assert(ex) +#endif + +char*alloc(int); + + +struct cluster { + /* Link to the next cluster. */ + struct cluster *next; + + /* The number of blocks in this cluster. */ + int num_blocks; + + /* Pointer to the first region. */ + struct region *first_region; + + /* Table index by the chunk number of some pointer minus the chunk */ + /* number for the first region giving the number of chunks past */ + /* the chunk holding the region header that spans that pointer. */ + /* Actually, it might not be enough. So after backing up that far, */ + /* try again. */ + unsigned char region_offset[1]; +}; + +/* The first word of this is arranged to look like a fixnum + * so as not to confuse 'room'. + */ +struct region { + unsigned + res1 :2, num_chunks :16, contains_small_objects :1, clean :1, hole :7; + struct region **prev; + struct region *next; + struct space *space; +}; + +#define REGION_OVERHEAD ROUNDUP(sizeof(struct region), ALIGN_BYTES) + + +struct space { + struct region *regions; + struct region **regions_tail; + char *alloc_ptr; + char *alloc_end; +}; + +/* Chain of all the clusters. */ +struct cluster *clusters = NULL; +static int num_clusters = 0; /* for debugging */ +int cgc_debug = 0; /* maybe set from Lisp */ +/* Table indexed by block number giving the cluster that block is part of. */ +static struct cluster **block_table = NULL; + +/* The allocated memory block_table is offset from. */ +static struct cluster **block_table_base = NULL; + +/* The maximum bounds on the heap. */ +static void *heap_base = NULL; +static void *heap_end = NULL; + +/* The two dynamic spaces. */ +static struct space space_0 = { NULL }; +static struct space space_1 = { NULL }; +/* Pointers it whichever dynamic space is currently newspace and oldspace */ +static struct space *newspace = NULL; +static struct space *oldspace = NULL; +/* Free lists of regions. */ +static struct region *small_region_free_list = NULL; +static struct region *large_region_free_list = NULL; +static void move_to_newspace(struct region *region); + +#if defined TESTING +static void print_region(struct region*r) +{ + dprintf(1,("[region %x %d <%x %x> %x]\n", + r,r->num_chunks,r->prev,r->next,r->space)); +} +static void print_regions(struct region*r, char*str) +{ + printf("Regions %s:\n",str); + for(; r != NULL; r = r->next) + print_region(r); +} + +static void print_space(struct space*s) +{ + struct region*r = s->regions; + dprintf(1,("[space %x %s %s <%x - %x>]\n", + s, + (s == &space_0)? "S0" : "S1", + (s == newspace)? "NewSpace" : "OldSpace", + s->alloc_ptr, s->alloc_end)); + print_regions(r,""); + +} +void print_spaces() +{ + print_space(&space_0); + print_space(&space_1); + print_regions(large_region_free_list,"LRFL"); + print_regions(small_region_free_list,"SRFL"); +} +void print_cluster(struct cluster*cluster) +{ + printf("[cluster %x >%x %d]\n",cluster,cluster->next,cluster->num_blocks); + print_regions(cluster->first_region,"cluster"); +} +void print_clusters() +{ + struct cluster*cluster; + for(cluster=clusters; cluster != NULL; cluster = cluster->next) + print_cluster(cluster); +} +#endif /* TESTING */ + + +/* Allocation/deallocation routines */ + +static void init_region(struct region *region, int nchunks) +{ + int region_block = BLOCK_NUMBER(region); + struct cluster *cluster = block_table[region_block]; + int offset = CHUNK_NUMBER(region) - CHUNK_NUMBER(cluster->first_region); + int i; + dprintf(0,("init region %x %d\n",region,nchunks)); + *(long*)region = 0; /* clear fields */ + region->num_chunks = nchunks; + if (nchunks > UCHAR_MAX) { + for (i = 0; i < UCHAR_MAX; i++) + cluster->region_offset[offset + i] = i; + for (; i < nchunks; i++) + cluster->region_offset[offset + i] = UCHAR_MAX; + } + else { + for (i = 0; i < nchunks; i++) + cluster->region_offset[offset + i] = i; + } +} + +static struct region *maybe_alloc_large_region(int nchunks) +{ + struct region *region, **prev; + + prev = &large_region_free_list; + while ((region = *prev) != NULL) { + if (region->num_chunks >= nchunks) { + if (region->num_chunks == nchunks) + *prev = region->next; + else { + struct region *new + = (struct region *)((char *)region + nchunks*CHUNK_BYTES); + init_region(new, region->num_chunks - nchunks); + new->next = region->next; + new->prev = NULL; + new->space = NULL; + *prev = new; + region->num_chunks = nchunks; + } + region->next = NULL; + region->prev = NULL; + region->space = NULL; + return region; + } + prev = ®ion->next; + } + return NULL; +} + + +/* from os_zero */ +static void cgc_zero(addr, length) +os_vm_address_t addr; +os_vm_size_t length; +{ + os_vm_address_t block_start = os_round_up_to_page(addr); + os_vm_address_t end = addr + length; + os_vm_size_t block_size; + + + if(block_start > addr) + bzero((char *)addr, MIN(block_start - addr, length)); + + if(block_start < end) + { + length -= block_start - addr; + + block_size =os_trunc_size_to_page(length); + + if(block_size < length) + bzero((char *)block_start + block_size,length - block_size); + + if (block_size != 0) + { + /* Now deallocate and allocate the block so that it */ + /* faults in zero-filled. */ + + os_invalidate(block_start,block_size); + addr=os_validate(block_start,block_size); + + if(addr == NULL || addr != block_start) + fprintf(stderr,"cgc_zero: block moved, 0x%08x ==> 0x%08x!\n", + block_start,addr); + } + } +} + +static void compact_cluster(struct cluster *cluster) +{ + int show = 0; + struct region *region = cluster->first_region; + struct region *end = + (struct region *)((char *)region + cluster->num_blocks * BLOCK_BYTES); + int grown = 0; + struct region *large_additions = NULL; + struct region **large_prev = &large_additions; + struct region *small_additions = NULL; + struct region **small_prev = &small_additions; + + dprintf(show,("compact cluster %x\n",cluster)); + while (region < end) { + struct region *next = + (struct region *) ((char *)region + region->num_chunks*CHUNK_BYTES); + if (region->space != newspace) { /* was == NULL */ + if (next < end && next->space != newspace) { /* was == NULL */ + gc_assert(region->space == NULL); + gc_assert(next->space == NULL); + gc_assert(region->num_chunks > 0); + gc_assert(next->num_chunks > 0); + region->num_chunks += next->num_chunks; + grown = 1; + } + else { + if (grown) { + init_region(region, region->num_chunks); + region->space = NULL; + grown = 0; + } + { + int ovh = REGION_OVERHEAD; + cgc_zero((os_vm_address_t)((char*)region + ovh), + (os_vm_size_t)(region->num_chunks*CHUNK_BYTES) - ovh); + } + + if(region->num_chunks == 1) { + *small_prev = region; + small_prev = ®ion->next; + } + else { + *large_prev = region; + large_prev = ®ion->next; + } + region = next; + } + } + else + region = next; + } + + *large_prev = large_region_free_list; + large_region_free_list = large_additions; + *small_prev = small_region_free_list; + small_region_free_list = small_additions; +} + +static void compact_free_regions() +{ + struct cluster*cluster; + large_region_free_list = NULL; + small_region_free_list = NULL; + + for (cluster = clusters; cluster != NULL; cluster = cluster->next) + compact_cluster(cluster); +} + +/* WL code arranged to allocate new space via the sbrk() mechanism. + * However, I am going to start by allocating from the standard dynamic + * space. The idea is to use the normal allocation scheme for initial + * system build and switch to the cgc allocator when starting up a + * saved image when dynamic space is hopefully clean. + */ +static struct region*new_region(int nblocks) +{ + /* take from existing dynamic space */ + char*new = (char*)SymbolValue(ALLOCATION_POINTER); + struct region*region = (struct region*)(ROUNDUP((long)new,BLOCK_BYTES)); + int bn = BLOCK_NUMBER(region); + new += (nblocks * BLOCK_BYTES + ((char*)region - new)); + SetSymbolValue(ALLOCATION_POINTER,(lispobj)new); + return region; +} + +static void new_cluster(int min_blocks) +{ + int nblocks = min_blocks < 4 ? 4 : min_blocks; + int nchunks = nblocks << (BLOCK_BITS-CHUNK_BITS); + int i; + struct cluster *cluster = malloc(sizeof(struct cluster) + nchunks-1); + struct region*region = new_region(nblocks); + + int bn = BLOCK_NUMBER(region); + dprintf(cgc_debug,("new cluster %x region@%x\n",cluster,region)); + for (i = 0; i < nblocks; i++) + block_table[bn+i] = cluster; + + num_clusters++; + cluster->next = clusters; + clusters = cluster; + cluster->num_blocks = nblocks; + cluster->first_region = region; + + init_region(region, nchunks); + + region->next = large_region_free_list; + large_region_free_list = region; + region->prev = NULL; + region->space = NULL; +} + +unsigned long cgc_bytes_allocated = 0; /* Seen by (dynamic-usage) */ +static unsigned long auto_gc_trigger = 0; +static int maybe_gc_called = 0; + +static struct region *alloc_large_region(int nchunks) +{ + struct region *region; + { + region = maybe_alloc_large_region(nchunks); + + if (region == NULL) + { + new_cluster((nchunks + BLOCK_CHUNKS - 1) >> (BLOCK_BITS-CHUNK_BITS)); + region = maybe_alloc_large_region(nchunks); + gc_assert(region != NULL); + } + } + gc_assert(region->space == NULL); + return region; +} + +static struct region *alloc_small_region() +{ + struct region *region = small_region_free_list; + + if (region == NULL) + region = alloc_large_region(1); + else + small_region_free_list = region->next; + region->next = NULL; + region->prev = NULL; + region->space = NULL; + move_to_newspace(region); + return region; +} + +static int chunks_freed = 0; + +static void free_region(struct region *region) +{ + gc_assert(region->space && region->space == oldspace); + gc_assert(region->num_chunks > 0); + + region->space = NULL; /* for compact_cluster? */ + region->prev = NULL; /* housekeeping I hope */ + chunks_freed += region->num_chunks; + + if (region->num_chunks == 1) + { + region->next = small_region_free_list; + small_region_free_list = region; + } + else + { + region->next = large_region_free_list; + large_region_free_list = region; + } +} + +static void *alloc_large(int nbytes) +{ + int nchunks = (nbytes+REGION_OVERHEAD+CHUNK_BYTES-1) >> CHUNK_BITS; + struct region *region = alloc_large_region(nchunks); + region->contains_small_objects = 0; + region->next = NULL; + region->prev = NULL; + region->space = NULL; + cgc_bytes_allocated += region->num_chunks*CHUNK_BYTES; + move_to_newspace(region); + return (char *)region + REGION_OVERHEAD; +} + +void *cgc_alloc(int nbytes) +{ + void*res; + dprintf(0,("alloc %d\n", nbytes)); + + if (nbytes > (CHUNK_BYTES - REGION_OVERHEAD)) + res = alloc_large(nbytes); + else + { + struct space *space = newspace; + if ((space->alloc_ptr + nbytes) > space->alloc_end) + { + struct region *region; + if(space->alloc_ptr != NULL) + { + int hole = space->alloc_end - space->alloc_ptr; + if(hole >= ALIGN_BYTES) + /* This wastes the space, eg suppose one cons + * has been allocated then a request for + * a maximum sized small obj comes in. I'd like + * to remember that there is still a lot of + * room left in this region. Maybe I could actually + * use the small_region_free_list in some way. + */ + NOTE_EMPTY(space->alloc_ptr, hole); + } + region = alloc_small_region(); + region->contains_small_objects = 1; + space->alloc_ptr = (char *)region + REGION_OVERHEAD; + space->alloc_end = (char *)region + CHUNK_BYTES; + cgc_bytes_allocated += region->num_chunks*CHUNK_BYTES; + } + + res = space->alloc_ptr; + space->alloc_ptr += ROUNDUP(nbytes, ALIGN_BYTES); + } + return res; +} + + +static void move_to_newspace(struct region *region) +{ + /* (maybe) unlink region from oldspace and add to tail of + * newspace regions. Don't attempt to move a region that + * is already in newspace. + */ + struct space *space = newspace; + if(region->space == oldspace) + { + /* Remove region from list. The prev slot holds + * the address of the 'next' slot of the previous + * list entry, not a pointer to that region (why?) + */ + *region->prev = region->next; + if(region->next) + region->next->prev = region->prev; + if(region->space->regions_tail == ®ion->next) + region->space->regions_tail = region->prev; + } + /* Append to newspace unless it has already been promoted. */ + if(region->space != newspace) + { + region->prev = space->regions_tail; + region->next = NULL; + *space->regions_tail = region; + space->regions_tail = ®ion->next; + region->space = space; + } +} + +static struct region *find_region(void *ptr) +{ + struct cluster *cluster; + int cluster_chunk_num; + int chunk_num; + unsigned char delta; + + ptr = (void*)((int) ptr & ~0x3); + if (ptr < heap_base || ptr >= heap_end) + return NULL; + + cluster = block_table[BLOCK_NUMBER(ptr)]; + if (cluster == NULL) + return NULL; + + if (ptr < (void*)cluster->first_region) + return NULL; + + cluster_chunk_num = CHUNK_NUMBER(cluster->first_region); + chunk_num = CHUNK_NUMBER(ptr); + + while (delta = cluster->region_offset[chunk_num - cluster_chunk_num]) + chunk_num -= delta; + + return CHUNK_ADDRESS(chunk_num); +} + +/* Interface to std collector */ +static inline boolean +from_space_p(lispobj obj) +{ + struct region*region=find_region((void*)obj); + return (region != NULL && region->space == oldspace); +} +static inline boolean +new_space_p(lispobj obj) +{ + struct region*region=find_region((void*)obj); + return (region != NULL && region->space == newspace); +} +static inline boolean +static_space_p(lispobj obj) +{ + return (STATIC_SPACE_START < obj + && obj < SymbolValue(STATIC_SPACE_FREE_POINTER)); +} + +/* Predicate that returns true if an object is a pointer. */ +#undef POINTERP +#define POINTERP(obj) Pointerp((obj)->header) + +/* Predicate that returns true if an object has been forwarded. */ +#define FORWARDED(obj) ((obj_t)(obj)->header == (obj_t)0x1) + +/* Returns the forwarding pointer for the given object. */ +#define FORWARDING_PTR(obj) ((lispobj)(obj)->data[0]) + +/* Marks obj as forwarded to new */ +#define DEPOSIT_FORWARDING_PTR(obj,new) \ + ((obj_t)(obj)->header = 0x1, (obj_t)(obj)->data[0] = (obj_t)new) + +/* Returns an obj_t for the object starting at addr */ +#define OBJECT_AT(addr) ((obj_t)(addr)) + +/* Returns the size (in bytes) of obj. */ +#define OBJECT_SIZE(obj) (sizeOfObject((obj_t)obj)<<2) + +/* Scavenges an object. */ +#define SCAVENGE_OBJECT(obj) scavengex((lispobj*)obj) + +#if 0 +/* Makes a region of memory look like some kind of object. */ +#define NOTE_EMPTY(ptr,bytes) \ + (((obj_t)ptr)->header = (((bytes+ALIGN_BYTES-1)>>ALIGN_BITS)<<8) | 1) +#endif + +static unsigned long bytes_copied = 0; +# define HAVE_FASTCOPY +#if defined HAVE_FASTCOPY +#define COPYDUAL(a,b,c) fastcopy16(a,b,c) +void fastcopy16(void*,void*,size_t); +#else +#define COPYDUAL(a,b,c) memmove(a,b,c) +#endif +static inline lispobj +copy(lispobj taggedobj) +{ + obj_t source = (obj_t)PTR(taggedobj); + int nbytes = OBJECT_SIZE(source); + gc_assert(Pointerp(taggedobj)); + gc_assert(!(nbytes & (ALIGN_BYTES-1))); + { + int lowtag = LowtagOf(taggedobj); + obj_t newobj = cgc_alloc(nbytes); + COPYDUAL(newobj, source, nbytes); + bytes_copied += nbytes; + return ((lispobj)newobj | lowtag); + } +} + + +#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1))) +#define NWORDS(x,y) (CEILING((x),(y)) / (y)) + +#define WEAK_POINTER_NWORDS \ + CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2) +static struct weak_pointer *weak_pointers; + + +/* Scavenging: + * CMU CL objects can be classified as BOXED, UNBOXED or other. + * Boxed objects have a header containing length and type followed + * by LENGTH tagged object descriptors which may be pointers. + * UNBOXED objects have a header but the data is other than + * tagged descriptors, such as floats, bignums, saps or code. + * Others (code) contain a mix of boxed and unboxed and some + * (cons) are like BOXED but without header. The scavenger needs + * to consider these different kinds of objects. I will use a + * table indexed by type to detect the simple cases of boxed + * or unboxed. + */ +#define IMMED_OR_LOSE(thing) gc_assert(sct[TypeOf(thing)].sc_kind == SC_IMMED) +static void scavenge_pointer(lispobj*); +static int noise = 0; + +typedef struct { unsigned sc_kind : 3, ve_l2bits : 5;} OSC_t; + +OSC_t make_OSC(int kind, int log2bits) +{ + OSC_t thing; + thing.sc_kind = kind; + thing.ve_l2bits = log2bits; + return thing; +} +#define SETSCT(indx,kind,logbits) sct[indx] = make_OSC(kind,logbits) +#define SC_ISBOXED 1 +#define SC_UNBOXED 2 +#define SC_IMMED 3 +#define SC_POINTER 4 +#define SC_VECTOR 5 +#define SC_STRING 6 +#define SC_OTHER 7 +#define SC_LOSER 0 +static OSC_t sct[256]; + +int sizeOfObject(obj_t obj) +{ + int obj_type = TypeOf(obj->header); + OSC_t class = sct[obj_type]; + struct vector*vector; + int length = 1; + int nwords = 1; + switch (class.sc_kind) + { + case SC_POINTER: + case SC_IMMED: + return 1; + case SC_ISBOXED: + case SC_UNBOXED: + gc_assert(HeaderValue(obj->header) > 0); + nwords = length = HeaderValue(obj->header) + 1; + break; + case SC_STRING: + case SC_VECTOR: + { + int log2bits = class.ve_l2bits; + int bits_per_el = 1 << log2bits; + int extra = 0; + int els_per_word = 1 << (5 - log2bits); + if(log2bits > 5) + { + els_per_word = 1; + extra = log2bits - 5; + } + length = ((struct vector*)obj)->length; + length = fixnum_value(length); /* Zero Length IS valid */ + length += (class.sc_kind == SC_STRING); + length <<= extra; + nwords = NWORDS(length, els_per_word); + nwords += 2; /* header + length */ + } + break; + case SC_OTHER: + switch(obj_type) + { + case type_CodeHeader: + { + struct code *code; + int nheader_words, ncode_words; + code = (struct code *)obj; + ncode_words = fixnum_value(code->code_size); + nheader_words = HeaderValue(code->header); + nwords = ncode_words + nheader_words; + } break; + default: + fprintf(stderr,"GC losage: no size for other type %d\n",obj_type); + gc_abort(); + } + break; + default: + fprintf(stderr,"GC losage: no size for other type %d\n",obj_type); + gc_abort(); + } + return CEILING(nwords,2); +} + +static void init_osc() +{ + int i; + for (i = 0; i < 256; i++) + SETSCT(i ,SC_LOSER, 0); + for (i = 0; i < 32; i++) + { + SETSCT(type_EvenFixnum|(i<<3) ,SC_IMMED,0); + SETSCT(type_FunctionPointer|(i<<3),SC_POINTER,0); + /* OtherImmediate0 */ + SETSCT(type_ListPointer|(i<<3) ,SC_POINTER,0); + SETSCT(type_OddFixnum|(i<<3) ,SC_IMMED,0); + SETSCT(type_InstancePointer|(i<<3),SC_POINTER,0); + /* OtherImmediate1 */ + SETSCT(type_OtherPointer|(i<<3) ,SC_POINTER,0); + } + SETSCT(type_Bignum ,SC_UNBOXED,0); + SETSCT(type_Ratio ,SC_ISBOXED,0); + SETSCT(type_SingleFloat ,SC_UNBOXED,0); + SETSCT(type_DoubleFloat ,SC_UNBOXED,0); + SETSCT(type_Complex ,SC_ISBOXED,0); + SETSCT(type_SimpleArray ,SC_ISBOXED,0); + SETSCT(type_SimpleString ,SC_STRING,3); + SETSCT(type_SimpleBitVector ,SC_VECTOR,0); + SETSCT(type_SimpleVector ,SC_VECTOR,5); + SETSCT(type_SimpleArrayUnsignedByte2 ,SC_VECTOR,1); + SETSCT(type_SimpleArrayUnsignedByte4 ,SC_VECTOR,2); + SETSCT(type_SimpleArrayUnsignedByte8 ,SC_VECTOR,3); + SETSCT(type_SimpleArrayUnsignedByte16 ,SC_VECTOR,4); + SETSCT(type_SimpleArrayUnsignedByte32 ,SC_VECTOR,5); + SETSCT(type_SimpleArraySingleFloat ,SC_VECTOR,5); + SETSCT(type_SimpleArrayDoubleFloat ,SC_VECTOR,6); + SETSCT(type_ComplexString ,SC_ISBOXED,0); + SETSCT(type_ComplexBitVector ,SC_ISBOXED,0); + SETSCT(type_ComplexVector ,SC_ISBOXED,0); + SETSCT(type_ComplexArray ,SC_ISBOXED,0); + SETSCT(type_CodeHeader ,SC_OTHER,0); + SETSCT(type_FunctionHeader ,SC_OTHER,0); + SETSCT(type_ClosureFunctionHeader ,SC_OTHER,0); + SETSCT(type_ReturnPcHeader ,SC_OTHER,0); + SETSCT(type_ClosureHeader ,SC_ISBOXED,0); + SETSCT(type_FuncallableInstanceHeader ,SC_ISBOXED,0); + SETSCT(type_ByteCodeFunction ,SC_ISBOXED,0); + SETSCT(type_ByteCodeClosure ,SC_ISBOXED,0); + SETSCT(type_DylanFunctionHeader ,SC_ISBOXED,0); + + SETSCT(type_ValueCellHeader ,SC_ISBOXED,0); + SETSCT(type_SymbolHeader ,SC_ISBOXED,0); + SETSCT(type_BaseChar ,SC_IMMED,0); + SETSCT(type_Sap ,SC_UNBOXED,0); + SETSCT(type_UnboundMarker ,SC_IMMED,0); + SETSCT(type_WeakPointer ,SC_UNBOXED,0); + SETSCT(type_InstanceHeader ,SC_ISBOXED,0); + SETSCT(type_Fdefn ,SC_ISBOXED,0); +} + +static lispobj* scavenge(lispobj*,int); +static lispobj*scavenge_object(lispobj*); +static lispobj*scavengex(lispobj*); + +static inline scavenge_1word_obj(lispobj*addr) +{ + if(Pointerp(*addr)) + { + if(*addr != NIL && *addr != T) + scavenge_pointer(addr); + } + else + IMMED_OR_LOSE(*addr); +} +static int debug_code = 0; +static int +scav_code_header(lispobj*where) +{ + lispobj object = *where; + struct code *code; + int i,nheader_words, ncode_words, nwords; + lispobj fheaderl; + struct function *fheaderp; + dprintf(0,("code: %x %x\n",where,object)); + code = (struct code *) where; + ncode_words = fixnum_value(code->code_size); + nheader_words = HeaderValue(object); + nwords = ncode_words + nheader_words; + nwords = CEILING(nwords, 2); + /* Scavenge the boxed section of the code data block */ + /* NOTE: seeing a problem where the trace_table_offset slot + * is a bogus list pointer instead of a fixnum such that + * junk gets moved to newspace which causes problems later. + * Purify doesn't look at that slot (a bug?). Need + * to figure out how it happens. Ans: from loading top-level + * forms that init byte-compiled functions like "defun fcn". + * Fix the loader to not do this and save some space! + */ + for(i=1; i < nheader_words; i++) + scavenge_1word_obj(where + i); + + /* Scavenge the boxed section of each function object in the + * code data block. + */ + fheaderl = code->entry_points; + while (fheaderl != NIL) { + fheaderp = (struct function *) PTR(fheaderl); + gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader); + scavenge_1word_obj(&fheaderp->name); + scavenge_1word_obj(&fheaderp->arglist); + scavenge_1word_obj(&fheaderp->type); + fheaderl = fheaderp->next; + } + return nwords; +} + +#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer) +#ifdef i386 +static void scavenge_fcn_header(struct function*object) +{ + struct function*fheader = object; + unsigned long offset = HeaderValue(fheader->header) * 4; + /* Ok, we don't transport code here, but we do need to + * scavenge the constants and functions (of which this is one). + * This should be done as part of scavenging a live code object + * and we could now be trying to do CPR on a corpse! + */ + struct code*code = (struct code *) ((unsigned long) fheader - offset); + gc_assert(TypeOf(fheader->header) == type_FunctionHeader); + scav_code_header((lispobj*)code); +} + +static int docode=0; /* maybe not needed */ +static int +scav_closure_header(struct closure*closure) +{ + /* Could also be a funcallable_instance. The x86 port has the + * raw code address in the function slot, not a lisp object. + * However, the function object is a known distance from the code. + */ + lispobj fun, fheader1; + int i,words; + gc_assert(ALIGNEDP(closure)); + words = HeaderValue(closure->header); + fun = closure->function - RAW_ADDR_OFFSET; + /* This needs to be done to get at live code. I now have no + * way to know if this has already been scavenged so I assume + * that it hasn't. Code that has been seen by purify is + * supposed RO and doesn't (shouldn't) need to be looked at + * so this maybe really redundant. + * + * I have seen one case where FI was incomplete with function + * and lexenv slots == 0! Is this a bug? + * + * Update, it appears this is not needed. I will disable execution + * by default but leave the code here in case something breaks. + */ + if(docode && static_space_p(closure->function)) + scavenge_fcn_header((struct function*)PTR(fun)); + else /* "normal" */ + scavenge_1word_obj(&fun); + + /* Now the boxed part of the closure header. */ + for(i = 0; i < words - 1; i++) + scavenge_1word_obj(&closure->info[i]); + + return CEILING(words + 1, 2); +} +static int fnoise=0; /* experimental */ +static int +scav_fdefn(lispobj*where) +{ + /* I don't know if this is really needs to be special cased here. + * raw_address should look like a fixnum and function is in static + * space -- unless it is pointing to something in C like closure_tramp + * or maybe undefined_tramp. + * Actually function is in dynamic space if it is a byte-function! + * Hmm, have seen case of function slot containing 1. Bug? + */ + struct fdefn * fdefn = (struct fdefn*)where; + int words = HeaderValue(fdefn->header); + int fix_func = ((char*)(fdefn->function+RAW_ADDR_OFFSET) == fdefn->raw_addr); + scavenge_pointer(&fdefn->name); + if(fnoise && LowtagOf(fdefn->function) == type_FunctionPointer) + { + obj_t fcnobj = (obj_t)PTR(fdefn->function); + switch(TypeOf(fcnobj->header)) + { + /* Can only be in static space and may need to scavenge code object. + * Won't be noticed by scavenge_pointer(). + */ + case type_FunctionHeader: + scavenge_fcn_header((struct function*)fcnobj); + break; + /* If in static space it was moved there by purify and we are + * doing normal scavenge. Handle normally. + */ + case type_FuncallableInstanceHeader: + case type_ClosureHeader: + scavenge_pointer(&fdefn->function); + break; + default: + dprintf(1,("Ignoring bogus value %x for fdefn function.\n", + *fcnobj)); + } + } + else + /* NIL for undefined function? */ + scavenge_pointer(&fdefn->function); + + if (fix_func) + { /* This shouldn't be needed yet. */ + fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET); + } + return sizeof(struct fdefn) / sizeof(lispobj); +} + +#endif + +/* List scavenger taken from gc.c and adapted */ + +static FILE*log=NULL; +static int scav_ro = 0; /* for testing */ +static int debug=0; +static void*trapaddr=0; +void check_trap(void*addr) +{ + fprintf(stderr,"Trapped @ %x\n",addr); +} + +static lispobj +trans_list(lispobj object) +{ + lispobj new_list_pointer; + struct cons *cons, *new_cons; + int n=0; + lispobj cdr; + + cons = (struct cons *) PTR(object); + + /* copy 'object' */ + new_cons = (struct cons *) cgc_alloc(sizeof(struct cons)); + new_cons->car = cons->car; + new_cons->cdr = cons->cdr; /* updated later */ + new_list_pointer = (lispobj)new_cons | LowtagOf(object); + bytes_copied += sizeof(struct cons); +#if 0 + if(scav_ro>1)check_trap(object); + if(log)fprintf(log,"( %d cons @ #x%x -> #x%x car #x%x)\n", + n++, cons,new_cons,new_cons->car); +#endif + /* Grab the cdr before it is clobbered */ + cdr = cons->cdr; + /* Set forwarding pointer (clobbers start of list). */ + DEPOSIT_FORWARDING_PTR((obj_t)cons,new_list_pointer); + + /* Try to linearize the list in the cdr direction to help reduce paging. */ + while (1) + { + lispobj new_cdr; + struct cons *cdr_cons, *new_cdr_cons; + + if (LowtagOf(cdr) != type_ListPointer + || !from_space_p(cdr) + || FORWARDED((obj_t)PTR(cdr)) ) + break; + + cdr_cons = (struct cons *) PTR(cdr); + + /* copy 'cdr' */ + new_cdr_cons = (struct cons*) cgc_alloc(sizeof(struct cons)); + new_cdr_cons->car = cdr_cons->car; + new_cdr_cons->cdr = cdr_cons->cdr; + new_cdr = (lispobj)new_cdr_cons | LowtagOf(cdr); + bytes_copied += sizeof(struct cons); +#if 0 + if(scav_ro>1)check_trap(object); + if(log)fprintf(log,"( %d cons @ #x%x -> #x%x car #x%x)\n", + n++,cdr_cons,new_cdr_cons,cdr_cons->car); +#endif + /* Grab the cdr before it is clobbered */ + cdr = cdr_cons->cdr; + /* Set forwarding pointer */ + DEPOSIT_FORWARDING_PTR((obj_t)cdr_cons,new_cdr); + + /* Update the cdr of the last cons copied into new + * space to keep the newspace scavenge from having to do it. + */ + new_cons->cdr = new_cdr; + + new_cons = new_cdr_cons; + } + + return new_list_pointer; +} + +/* Weak Pointers */ +static int weak_noise=0; +static int do_weak=1; +static int +scav_weak_pointer(lispobj*where) +{ + struct weak_pointer*wp = weak_pointers; + /* Push the weak pointer onto the list of weak pointers. + * Do I have to watch for duplicates? Originally this was + * part of trans_weak_pointer but that didn't work in the + * case where the WP was in a promoted region. + */ + + while(wp != NULL) + { + if(wp == (struct weak_pointer*)where) + break; + wp = wp->next; + } + if(wp == NULL) + { + wp = (struct weak_pointer*)where; + wp->next = weak_pointers; + weak_pointers = wp; + if(!do_weak)scavenge_1word_obj(&wp->value); + } + + /* Do not let GC scavenge the value slot of the weak pointer + * (that is why it is a weak pointer). + */ + + return WEAK_POINTER_NWORDS; +} +void scan_weak_pointers(void) +{ + struct weak_pointer *wp; + for (wp = weak_pointers; wp != NULL; wp = wp->next) + { + lispobj value = wp->value; + obj_t obj = (obj_t)PTR(value); + lispobj first, *first_pointer; + + dprintf(weak_noise,("Weak pointer at 0x%08x\n", (unsigned long) wp)); + dprintf(weak_noise,("Value: 0x%08x\n", (unsigned long) value)); + + if (Pointerp(value) && from_space_p(value)) + { + /* Now, we need to check if the object has been forwarded. + * If it has been, the weak pointer is still good and needs + * to be updated. Otherwise, the weak pointer needs to be nil'ed out. + */ + + if(FORWARDED(obj)) + wp->value = FORWARDING_PTR(obj); + else + { /* break it */ + dprintf(weak_noise,("Broken.\n")); + wp->value = NIL; + wp->broken = T; + } + } + } +} + +static int +scavenge_random_object(lispobj*addr) +{ + lispobj header = *addr; + int count = 1; + dprintf(noise > 1,("soi: %x @ %x\n",header,addr)); +#if 0 + if(trapaddr==addr) + check_trap(addr); +#endif + gc_assert(ALIGNEDP(addr)); + + switch (TypeOf(header)) + { + case type_SimpleVector: + { + struct vector*v = (struct vector*)addr; + int i, n = fixnum_value(v->length); + if (HeaderValue(v->header) == subtype_VectorValidHashing) + v->header = (subtype_VectorMustRehash<<type_Bits)|type_SimpleVector; + /* Look at each of the vector elements which can be any lisp object. */ + for(i=0; i<n; i++) + scavenge_1word_obj(&v->data[i]); + count = CEILING(n+2, 2); + } + break; + case type_CodeHeader: + count = scav_code_header(addr); + break; + /* We should never hit any of these, 'cause they occur buried in + * the middle of code objects (and handled by the code just above). + */ + case type_ClosureFunctionHeader: + case type_ReturnPcHeader: + gc_abort(); + + /* Except while looking at an fdefn and wanting to ensure + * code object is looked at. + */ + case type_FunctionHeader: + scavenge_fcn_header((struct function *)addr); + break; +#if defined i386 + case type_ClosureHeader: + case type_FuncallableInstanceHeader: + case type_ByteCodeFunction: + case type_ByteCodeClosure: + case type_DylanFunctionHeader: + count = scav_closure_header((struct closure *)addr); + break; +#endif + case type_WeakPointer: + count = scav_weak_pointer(addr); + break; + case type_Fdefn: + /* We have to handle fdefn objects specially, so we can fix + * up the raw function address. + */ + count = scav_fdefn(addr); + break; + default: + { + OSC_t class = sct[TypeOf(header)]; + switch(class.sc_kind) + { + case SC_IMMED: + count = 1; + break; + case SC_ISBOXED: + { + int i, words = 1+ HeaderValue(header); + for(i=1; i<words; i++) + scavenge_1word_obj(addr+i); + count = CEILING(words, 2); + } + break; + case SC_UNBOXED: + case SC_STRING: + case SC_VECTOR: /* simple vector handled above */ + count = sizeOfObject((obj_t)addr); + break; + default: + gc_abort(); + } + } + } + return count; +} + +static void logcopy(lispobj*addr, lispobj tagged, int hdr, lispobj to) +{ + if(log) + { + int kind = TypeOf(hdr); + int words = sizeOfObject((obj_t)PTR(tagged)); + fprintf(log,"(copy #x%x @ #x%x (#x%x %d) to #x%x)\n", + tagged,addr,kind,words,to); + } +} +static void +maybe_transport(lispobj*addr, lispobj tagged, struct region*region) +{ + obj_t obj = (obj_t)PTR(tagged); + gc_assert(ALIGNEDP(obj)); + gc_assert(Pointerp(tagged)); + gc_assert((void*)region != (void*)obj); +#if 0 + if((void*)obj == (void*)trapaddr) + check_trap(obj); +#endif + if (region->contains_small_objects) + { + lispobj new = copy(tagged); +#if 0 + if(scav_ro > 1) /* debugging in RO space */ + check_trap(obj); +#endif +#if defined GOOSE_CHASE + if(TypeOf(obj->header)==type_Fdefn) + { + struct fdefn*fdefn=(struct fdefn*)PTR(new); + if(fdefn->function < STATIC_SPACE_START) + check_trap(obj); + } +#endif + dprintf(0,("copy %x @ %x (%x) to %x\n", + tagged,addr,TypeOf(obj->header),new)); + logcopy(addr,tagged,obj->header,new); + DEPOSIT_FORWARDING_PTR(obj , new); + *addr = new; + } + else + { + move_to_newspace(region); + dprintf(0,("move %x\n",region)); + } +} + +void +scavenge_pointer(lispobj*addr) +{ + lispobj taggedobj = *addr; /* descriptor */ + obj_t obj = (obj_t)PTR(taggedobj); /* pointer to object */ + gc_assert(Pointerp(taggedobj)); +#if 0 + if(addr == trapaddr) check_trap(addr); + if(obj == trapaddr) check_trap(obj); +#endif + /* optimize out common static pointers */ + if(taggedobj != NIL && taggedobj != T) + { + struct region*region = find_region(obj); + /* Only interested in pointers into oldspace */ + if(region && region->space == oldspace) + { + if(FORWARDED(obj)) + *addr = FORWARDING_PTR(obj); + else + switch (LowtagOf(taggedobj)) + { + case type_ListPointer: + dprintf(noise>1,("ListPointer @ %x...\n",addr)); + *addr = trans_list(taggedobj); + dprintf(noise>1,("... -> %x\n",addr)); + break; + case type_FunctionPointer: + switch(TypeOf(obj->header)) + { + case type_ClosureHeader: + case type_FuncallableInstanceHeader: + case type_ByteCodeFunction: + case type_ByteCodeClosure: + case type_DylanFunctionHeader: + maybe_transport(addr, taggedobj, region); + break; + default: + gc_abort(); + } + break; + case type_InstancePointer: + case type_OtherPointer: + maybe_transport(addr, taggedobj, region); + break; + default: + /* It was a pointer, but not one of them? */ + gc_abort(); + } + } + } +} + + +static lispobj*scavenge(lispobj*addr, int ptrs) +{ + /* addr points to an aligned 32-bit word in some space. */ + struct region *region; + lispobj*end = addr + ptrs; + lispobj obj; + while (addr < end) + { + int count = 1; + obj = *addr; /* the lisp object */ +#if 0 + if(trapaddr == addr) + check_trap(addr); /* gdb breakpoint */ +#endif + if (Pointerp(obj)) /* lowtag odd */ + scavenge_pointer(addr); + else if(obj & 0x3) /* some other immediate */ + /* + * Some random header. Process some type dependent number + * of words. May still be inside object after call and the + * next cell can be any lisp object. We can either recurse + * by calling scavenge here or let the caller do it. + */ + count = scavenge_random_object(addr); + else + IMMED_OR_LOSE(obj); + + addr += count; + } + return addr; +} + +static void +scavenge_cons(lispobj*where) +{ + /* Scavenge a two-word space */ + scavenge_1word_obj(where + 0); /* car */ + scavenge_1word_obj(where + 1); /* cdr */ +} +static lispobj*scavenge_object(lispobj*start) +{ + int length = sizeOfObject((obj_t)start); + int words = scavenge_random_object(start); + gc_assert(length == words); + return start+length; +} +static lispobj* +scavengex(lispobj*obj) +{ + /* Thing at this location is one of: + * a - basic object with header. + * b - cons object (no header). + * so that the starting and ending addresses are aligned. + */ + gc_assert(ALIGNEDP(obj)); + { + lispobj first_word = *obj; + OSC_t sc = sct[TypeOf(first_word)]; + if(Pointerp(first_word) || sc.sc_kind == SC_IMMED) + { /* Must be a cons object or unused space */ + scavenge_cons((lispobj*)obj); + return obj + 2; + } + else + { /* Must be a complex object with header */ + lispobj*next = scavenge_object(obj); + return next; + } + } +} + +static void +scavenge_space( lispobj*where, int words, char*name ) +{ + int allocated = cgc_bytes_allocated; + lispobj*end = where + words; + lispobj*last; + bytes_copied = 0; + if(name) + dprintf(noise,(" %s",name)); + while (where < end) + { + last = where; + where = scavengex(last); + } + gc_assert(where == end); + if(name) + dprintf(noise,(" %ld bytes moved, %ld bytes allocated.\n", + bytes_copied, cgc_bytes_allocated - allocated)); +} + +static int boxed_registers[] = BOXED_REGISTERS; +static void +preserve_interrupt_context(struct sigcontext *context) +{ + int i; + /* Check each boxed register for a valid pointer and promote + * its region when found. + */ + for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) + { + int index = boxed_registers[i]; + lispobj foo = SC_REG(context,index); + struct region*region = find_region((void*)foo); + if(region && region->space == oldspace) + move_to_newspace(region); + } +} +static void preserve_interrupt_contexts(void) +{ + int i, index; + struct sigcontext *context; + + index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)); + dprintf(noise,("Number of active contexts: %d\n", index)); + + for (i = 0; i < index; i++) + { + context = lisp_interrupt_contexts[i]; + preserve_interrupt_context(context); + } +} + + +static void flip_spaces() +{ + struct space *temp = oldspace; + oldspace = newspace; + newspace = temp; +} + +/* There should be no lisp objects on the C stack so will limit search + * to just the assigned lisp stack area. + */ +#if defined i386 +#define BOS (CONTROL_STACK_START+CONTROL_STACK_SIZE) /* x86-validate.h */ +/* Traverse stack in same direction as it was loaded to try and + * preserve original ordering of pages. Good for the VM system I hope. + */ +#define ACROSS_STACK(var) var=(void**)BOS-1; var > (void**)&var; var-- +#endif + +static void preserve_stack() +{ + void **addr; /* auto var is current TOS */ + for (ACROSS_STACK(addr)) + { + void *ptr = *addr; + if (ptr > heap_base && ptr < heap_end) + { + struct region *region = find_region(ptr); + if (region != NULL && region->space == oldspace) + { + dprintf(0,("move %x\n",ptr)); + move_to_newspace(region); + } + } + } +} +static void zero_stack() +{ + /* This is a bit tricky because we don't want to zap any + * stack frames between here and the call to mmap. For now, + * lets just be slow and careful. + */ + long*p,*q; + os_vm_address_t base = (os_vm_address_t)CONTROL_STACK_START; + os_vm_size_t size = (char*)&base - (char*)base; +#if 0 + cgc_zero(base,size); +#else + p = (long*)base; + q = (long*)&size; + while(p < q) + *p++ = 0; +#endif + +} + +#if defined STATIC_BLUE_BAG +static int fast_static=1; +static void scavenge_static() +{ + /* Static space consists of alternating layers of + * code objects that refer to read-only space (from purify), + * static non-code objects that need looking at, and + * newly loaded code objects that refer to dynamic space. + * The number of these areas depends on how many times purify + * ran while loading the system image. I will extend purify + * to maintain a list of collectable areas and use that list + * here to avoid scanning read-only code sections. + */ + lispobj*ss0 = (lispobj*)PTR(NIL); + lispobj*ssa = (lispobj*)(PTR(STATIC_BLUE_BAG)); + lispobj*ssz = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER); + lispobj bag = SymbolValue(STATIC_BLUE_BAG); + lispobj*end = NULL; + ssa += sizeOfObject(OBJECT_AT(ssa)); /* Genesis modifies plist entry */ + if(fast_static) + { + scavenge_space(ss0, ssa-ss0, "Static0"); + if(bag != NIL && LowtagOf(bag) == type_ListPointer) + { + char sbuf[128]; + struct cons*cons = (struct cons*)PTR(bag); + while(LowtagOf(cons->car) == type_ListPointer) + { + struct cons*pair = (struct cons*)PTR(cons->car); + lispobj*ss1 = (lispobj*)pair->car; + lispobj*ss2 = (lispobj*)pair->cdr; + if(end == NULL) + end = ss2; + sprintf(sbuf,"Static %x %d",ss1, ss2-ss1); + scavenge_space(ss1, ss2-ss1, sbuf); + if(cons->cdr != NIL && LowtagOf(cons->cdr) == type_ListPointer) + cons = (struct cons*)PTR(cons->cdr); + else break; + } + } + if(end != NULL) + scavenge_space(end, ssz-end, "Static"); + } + else (scavenge_space(ss0, ssz-ss0, "Static-All")); +} +#endif + +static void scavenge_roots() +{ + /* So what should go here? + * When cgc starts up after purify/save all live objects + * are in read-only or static space, and anything in RO + * can point only to RO or STATIC and can't be changed. + * Anything in STATIC is subject to change (but not move). + * . not read-only-space (probably most of the roots here) + * . static-space (all compiled code at least) + * . binding-stack + * . weak-pointers + ? do I allow GC from interrupt?) + * . interrupt-context (regs same as stack) + **** + * Well, it turns out that RO space ain't exactly that as + * somehow apparently cached 'compact-info-environment' stuff + * modifies at least 2 locations in RO space. There is a note + * in globaldb.lisp that alludes to this and provides a post GC + * hook to blow the cache. Not a problem if gc is called from + * the lisp wrapper. UPDATE: Found purify bug which forced + * boxed vectors into RO. This may be what led to above. + * + */ + lispobj*rs0 = (lispobj*)READ_ONLY_SPACE_START; + lispobj*rsz = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER); + lispobj*ss0 = (lispobj*)STATIC_SPACE_START; + lispobj*ssz = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER); + lispobj*bs0 = (lispobj*)BINDING_STACK_START; + lispobj*bsz = (lispobj*)SymbolValue(BINDING_STACK_POINTER); + + if(scav_ro) + { + scav_ro++; + scavenge_space(rs0, rsz-rs0, "RO"); + scav_ro--; + } + scavenge_static(); + scavenge_space(bs0, bsz-bs0, "Binding Stack"); + + dprintf(noise,("Interrupt handlers (%u bytes) ...\n", + sizeof(interrupt_handlers))); + + scavenge((lispobj *) interrupt_handlers, + sizeof(interrupt_handlers) / sizeof(lispobj)); + +} + +static void scavenge_newspace() +{ + /* Scavenge is going to start at the beginning of newspace which + * is presumed to have some "root" object pointers lying about due + * to promoting regions that may be aimed at by stack resident pointers, + * copied small objects from scavenge_roots(), or promoted large_object + * regions. Scavenge() will flush out more copied objects/promoted + * regions that will get added to the end of newspace and eventually + * scanned by this code -- until all referenced things (and maybe some + * extra dead stuff) have been examined. At the end of this loop anything + * in oldspace is trash. + */ + struct region *current; + current = newspace->regions; + + while (current != NULL) + { + if (current->contains_small_objects) + { + void *obj = (char *)current + REGION_OVERHEAD; + void *end = (char *)current + current->num_chunks*CHUNK_BYTES; + while (obj < end) + obj = SCAVENGE_OBJECT(OBJECT_AT(obj)); + gc_assert(obj == end); + } + else + SCAVENGE_OBJECT(OBJECT_AT(((char *)current + REGION_OVERHEAD))); + current = current->next; + } +} + +static void free_oldspace() +{ + struct region *region, *next; + chunks_freed = 0; + for (region = oldspace->regions; region != NULL; region = next) + { + gc_assert(region->space != newspace); + next = region->next; + free_region(region); + } + oldspace->alloc_ptr = NULL; + oldspace->alloc_end = NULL; + oldspace->regions = NULL; + oldspace->regions_tail = &oldspace->regions; +} + +static void verify_space(lispobj*start, size_t words) +{ + while(words > 0) + { + size_t count = 1; + lispobj thing = *(lispobj*)start; + if(Pointerp(thing)) + { + struct region*region = find_region((void*)thing); + if(region && region->space == NULL) + fprintf(stderr,"Ptr %x @ %x sees Junk\n",thing,start); + } + else + if(thing & 0x3) + { + obj_t obj = (obj_t)start; + switch(TypeOf(obj->header)) + { + case type_CodeHeader: + { + lispobj object = *start; + struct code *code; + int nheader_words, ncode_words, nwords; + lispobj fheaderl; + struct function *fheaderp; + + code = (struct code *) start; + ncode_words = fixnum_value(code->code_size); + nheader_words = HeaderValue(object); + nwords = ncode_words + nheader_words; + nwords = CEILING(nwords, 2); + /* Scavenge the boxed section of the code data block */ + verify_space(start + 1, nheader_words - 1); + + /* Scavenge the boxed section of each function object in the + * code data block. + */ + fheaderl = code->entry_points; + while (fheaderl != NIL) { + fheaderp = (struct function *) PTR(fheaderl); + gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader); + verify_space(&fheaderp->name, 1); + verify_space(&fheaderp->arglist, 1); + verify_space(&fheaderp->type, 1); + fheaderl = fheaderp->next; + } + count = nwords; + break; + } + default: + { + OSC_t class = sct[TypeOf(obj->header)]; + switch(class.sc_kind) + { + case SC_ISBOXED: + case SC_IMMED: + count = 1; + break; + case SC_UNBOXED: + case SC_STRING: + case SC_VECTOR: + count = sizeOfObject((obj_t)start); + break; + default: + gc_abort(); + } + break; + } + } + } + start += count; + words -= count; + } +} + +/* For debug/test only. */ +static void +verify_gc() +{ + lispobj*rs0 = (lispobj*)READ_ONLY_SPACE_START; + lispobj*rsz = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER); + lispobj*ss0 = (lispobj*)STATIC_SPACE_START; + lispobj*ssz = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER); + lispobj*bs0 = (lispobj*)BINDING_STACK_START; + lispobj*bsz = (lispobj*)SymbolValue(BINDING_STACK_POINTER); + lispobj*cs0 = (lispobj*)&rs0; + lispobj*csz = (lispobj*)BOS; + /* can't check stack easily because there may be non-valid + * objects there (thats why we're doing this cgc stuff. In + * particular there are raw return addresses which can be very + * descriptorish looking!!! + + verify_space(cs0, csz-cs0); + */ + verify_space(rs0, rsz-rs0); + verify_space(ss0, ssz-ss0); + verify_space(bs0, bsz-bs0); +} + +static int dolog=0; /* log copy ops to file */ +static int dover=0; /* hunt pointers to oldspace */ +void cgc_collect_garbage() +{ + unsigned long allocated = cgc_bytes_allocated; + + dprintf(noise,("GC\n")); + if(dolog && !log) + log=fopen("LOG.tmp","w"); + + /* Initialize the weak pointer list. */ + weak_pointers = NULL; + + dprintf(noise,("[Flip Spaces]\n")); + flip_spaces(); + preserve_interrupt_contexts(); + dprintf(noise,("[Preserve Stack]\n")); + preserve_stack(); + dprintf(noise,("[Scavenge Roots]\n")); + scavenge_roots(); + dprintf(noise,("[Scavenge New]\n")); + scavenge_newspace(); + scan_weak_pointers(); + dprintf(noise,("[Free Oldspace]\n")); + free_oldspace(); + if(dover) { + dprintf(noise,("[Checking]\n")); + verify_gc();} + dprintf(noise,("[Compacting]\n")); + compact_free_regions(); + /* The stack will be zeroed by scrub-control-stack in sub-gc which + is more effecient. */ + /* zero_stack(); */ + if(log) + fclose(log); + log=NULL; + dprintf(noise,(" %ld bytes copied.\n",(cgc_bytes_allocated - allocated))); + dprintf(noise,(" %ld bytes (%ld pages) reclaimed.\n", + chunks_freed*CHUNK_BYTES, chunks_freed)); + cgc_bytes_allocated -= chunks_freed*CHUNK_BYTES; + maybe_gc_called = 0; +} +void cgc_free_heap() +{ + /* Like above but just zap everything 'cause purify has + * cleaned house! + */ + unsigned long allocated = cgc_bytes_allocated; + flip_spaces(); + free_oldspace(); + compact_free_regions(); +#if 0 /* purify is currently running on the C stack so don't do this */ + zero_stack(); +#endif + cgc_bytes_allocated -= chunks_freed*CHUNK_BYTES; +} + + +void +cgc_init_collector() +{ + int max_blocks; + heap_base = (void*)DYNAMIC_0_SPACE_START; + + /* I could actually use both spaces here but just 1 for now */ + heap_end = (char*)heap_base + DYNAMIC_SPACE_SIZE; + + max_blocks = BLOCK_NUMBER(heap_end) - BLOCK_NUMBER(heap_base); + if((block_table_base = malloc(sizeof(struct cluster *) * max_blocks)) + != NULL) + { + memset(block_table_base, 0, sizeof(struct cluster *) * max_blocks); + block_table = (block_table_base - BLOCK_NUMBER(heap_base)); + + space_0.regions_tail = &space_0.regions; + space_1.regions_tail = &space_1.regions; + + newspace = &space_0; + oldspace = &space_1; + } + else perror("malloc cgc block table"); + init_osc(); /* Object Storage Class table */ +} + + +void do_pending_interrupt(void); + +int use_cgc_p = 0; +char*alloc(int nbytes) +{ + /* Alloc is only called from lisp code to allocate a number of + words, the cgc GC uses cgc_alloc directly as the checks of the + heap size and is not needed and interrupts are allways disabled + during a GC. */ + + /* Assumes nbytes includes alignment. Python arranges for that + * but the C startup code needed some help. + */ +#if 0 + int bytes = (nbytes + (ALIGN_BYTES-1)) & ~(ALIGN_BYTES-1); + if(bytes != nbytes) + fprintf(stderr,"Fixing unaligned allocation length %d.\n",nbytes); + nbytes = bytes; +#endif + if(!use_cgc_p) + { + char*current = (char*)SymbolValue(ALLOCATION_POINTER); + char*nxtfree = current + nbytes; + SetSymbolValue(ALLOCATION_POINTER, (lispobj)nxtfree); + return current; + } + else + { + /* Lacking an interrupt driven scheme to notice when a GC might + * be wise, we add some more overhead to the allocator here + * before any needed state is acquired. Only need to do it once + * though because lisp will remember *need to collect garbage* + * and get to it when it can. */ + if( auto_gc_trigger /* Only when enabled */ + && cgc_bytes_allocated > auto_gc_trigger + && !maybe_gc_called++) /* Only once */ + funcall0(SymbolFunction(MAYBE_GC)); + + if (SymbolValue(INTERRUPTS_ENABLED) == NIL) + /* Interrupts are disable so no special care is needed */ + return cgc_alloc(nbytes); + else + { + void *result; + /* Interrupts are enabled so set *interrupt-enabled* to nil + before calling cgc_alloc to prevent cgc_alloc from being + re-entered. */ + SetSymbolValue(INTERRUPTS_ENABLED, NIL); + + result = cgc_alloc(nbytes); + + /* Restore *interrupts-enabled* */ + SetSymbolValue(INTERRUPTS_ENABLED, T); + + /* Check if an interrupt occured */ + if (SymbolValue(INTERRUPT_PENDING) == T) + /* Handle any interrupts that occured during cgc_alloc */ + do_pending_interrupt(); + + return result; + } + } +} + +/* Interface to history. */ +void set_auto_gc_trigger(unsigned long dynamic_usage) +{ + auto_gc_trigger += dynamic_usage; +} +void clear_auto_gc_trigger(void) +{ + auto_gc_trigger = 0; +} +void gc_init(void) +{ + cgc_init_collector(); +} +void collect_garbage() +{ + /* SUB-GC wraps without-interrupt around call, but this + * is going to absolutely block SIGINT. + */ + /* #define REALLY_SAFE */ +#if defined REALLY_SAFE + sigset_t newmask,oldmask; + sigemptyset(&newmask); + sigaddset(&newmask, SIGINT); + sigprocmask(SIG_BLOCK, &newmask, &oldmask); +#endif + cgc_collect_garbage(); +#if defined REALLY_SAFE + sigprocmask(SIG_SETMASK, &oldmask, NULL); +#endif + +} diff --git a/lisp/cgc.h b/lisp/cgc.h new file mode 100644 index 000000000..18dc9e5ba --- /dev/null +++ b/lisp/cgc.h @@ -0,0 +1,7 @@ +/* cgc.h -*- Mode: C; comment-column: 40; -*- + * + * Conservative GC for CMUCL X86 + * + */ +void*cgc_alloc(int); +void cgc_free_heap(void); diff --git a/lisp/coreparse.c b/lisp/coreparse.c index 8d0c88796..59c9ad1c3 100644 --- a/lisp/coreparse.c +++ b/lisp/coreparse.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/coreparse.c,v 1.4 1994/07/05 16:06:45 hallgren Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/coreparse.c,v 1.5 1997/01/21 00:28:13 ram Exp $ */ #include <stdio.h> #include <sys/types.h> #include <sys/file.h> @@ -35,12 +35,12 @@ static void process_directory(int fd, long *ptr, int count) if (len != 0) { os_vm_address_t real_addr; #ifdef PRINTNOISE - printf("Mapping %d bytes at 0x%x.\n", len, addr); + printf("Mapping %ld bytes at 0x%lx.\n", len, addr); #endif real_addr=os_map(fd, offset, addr, len); if(real_addr!=addr) fprintf(stderr, - "process_directory: file mapped in wrong place! (0x%08x != 0x%08x)\n", + "process_directory: file mapped in wrong place! (0x%08x != 0x%08lx)\n", real_addr, addr); } @@ -55,7 +55,7 @@ static void process_directory(int fd, long *ptr, int count) && addr != (os_vm_address_t)dynamic_1_space) printf("Strange ... dynamic space lossage.\n"); current_dynamic_space = (lispobj *)addr; -#ifdef ibmrt +#if defined(ibmrt) || defined(i386) SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer); #else current_dynamic_space_free_pointer = free_pointer; @@ -68,7 +68,7 @@ static void process_directory(int fd, long *ptr, int count) /* Don't care about read only space */ break; default: - printf("Strange space ID: %d; ignored.\n", id); + printf("Strange space ID: %ld; ignored.\n", id); break; } entry++; @@ -105,7 +105,7 @@ lispobj load_core_file(char *file) val = *ptr++; if (val != CORE_MAGIC) { - fprintf(stderr, "Invalid magic number: 0x%x should have been 0x%x.\n", + fprintf(stderr, "Invalid magic number: 0x%lx should have been 0x%x.\n", val, CORE_MAGIC); exit(1); } @@ -147,7 +147,7 @@ lispobj load_core_file(char *file) break; default: - printf("Unknown core file entry: %d; skipping.\n", val); + printf("Unknown core file entry: %ld; skipping.\n", val); break; } diff --git a/lisp/dynbind.c b/lisp/dynbind.c index 839c1bd7b..e2dbcbac3 100644 --- a/lisp/dynbind.c +++ b/lisp/dynbind.c @@ -1,5 +1,5 @@ /* - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/dynbind.c,v 1.1 1992/07/28 20:14:22 wlott Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/dynbind.c,v 1.2 1997/01/21 00:28:13 ram Exp $ * * Support for dynamic binding from C. */ @@ -9,7 +9,7 @@ #include "globals.h" #include "dynbind.h" -#ifdef ibmrt +#if defined(ibmrt) || defined(i386) #define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER)) #define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value)) #else diff --git a/lisp/globals.c b/lisp/globals.c index a8d9595d5..bc03c1880 100644 --- a/lisp/globals.c +++ b/lisp/globals.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.c,v 1.1 1992/07/28 20:14:29 wlott Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.c,v 1.2 1997/01/21 00:28:13 ram Exp $ */ /* Variables everybody needs to look at or frob on. */ @@ -21,6 +21,9 @@ lispobj *static_space; lispobj *dynamic_0_space; lispobj *dynamic_1_space; lispobj *control_stack; +#ifdef i386 +lispobj *control_stack_end; +#endif lispobj *binding_stack; lispobj *current_dynamic_space; @@ -45,7 +48,12 @@ void globals_init(void) foreign_function_call_active = 1; /* Initialize the current lisp state. */ +#ifndef i386 current_control_stack_pointer = control_stack; +#else + current_control_stack_pointer = control_stack_end; +#endif + current_control_frame_pointer = (lispobj *)0; #ifndef BINDING_STACK_POINTER current_binding_stack_pointer = binding_stack; diff --git a/lisp/globals.h b/lisp/globals.h index c6265ac9d..207e368dc 100644 --- a/lisp/globals.h +++ b/lisp/globals.h @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.h,v 1.3 1994/10/24 20:03:32 ram Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/globals.h,v 1.4 1997/01/21 00:28:13 ram Exp $ */ #if !defined(_INCLUDE_GLOBALS_H_) #define _INCLUDED_GLOBALS_H_ @@ -11,7 +11,7 @@ extern int foreign_function_call_active; extern lispobj *current_control_stack_pointer; extern lispobj *current_control_frame_pointer; -#ifndef ibmrt +#if !defined(ibmrt) && !defined(i386) extern lispobj *current_binding_stack_pointer; #endif @@ -21,9 +21,11 @@ extern lispobj *dynamic_0_space; extern lispobj *dynamic_1_space; extern lispobj *control_stack; extern lispobj *binding_stack; - +#ifdef i386 +extern lispobj *control_stack_end; +#endif extern lispobj *current_dynamic_space; -#ifndef ibmrt +#if !defined(ibmrt) && !defined(i386) extern lispobj *current_dynamic_space_free_pointer; extern lispobj *current_auto_gc_trigger; #endif @@ -48,11 +50,19 @@ extern void globals_init(void); #define EXTERN(name,bytes) .globl _/**/name #endif +#ifdef i386 +#ifdef __linux__ +#define EXTERN(name,bytes) .globl _/**/name +#else +#define EXTERN(name,bytes) .global _ ## name +#endif +#endif + EXTERN(foreign_function_call_active, 4) EXTERN(current_control_stack_pointer, 4) EXTERN(current_control_frame_pointer, 4) -#ifndef ibmrt +#if !defined(ibmrt) && !defined(i386) EXTERN(current_binding_stack_pointer, 4) EXTERN(current_dynamic_space_free_pointer, 4) #endif diff --git a/lisp/interr.c b/lisp/interr.c index 0b6117a18..5e892139e 100644 --- a/lisp/interr.c +++ b/lisp/interr.c @@ -1,5 +1,5 @@ /* - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interr.c,v 1.2 1994/10/24 20:04:27 ram Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interr.c,v 1.3 1997/01/21 00:28:13 ram Exp $ * * Stuff to handle internal errors. * @@ -113,10 +113,10 @@ void internal_error(struct sigcontext *context) printf("\t0x%08x\n", SC_REG(context, offset)); break; case sc_SignedReg: - printf("\t%ld\n", SC_REG(context, offset)); + printf("\t%d\n", SC_REG(context, offset)); break; case sc_UnsignedReg: - printf("\t%lu\n", SC_REG(context, offset)); + printf("\t%u\n", SC_REG(context, offset)); break; #ifdef sc_SingleFloatReg case sc_SingleFloatReg: diff --git a/lisp/interrupt.c b/lisp/interrupt.c index 661e88eaf..d89f90d36 100644 --- a/lisp/interrupt.c +++ b/lisp/interrupt.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.5 1994/10/24 20:05:30 ram Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/interrupt.c,v 1.6 1997/01/21 00:28:13 ram Exp $ */ /* Interrupt handing magic. */ @@ -26,6 +26,7 @@ #include "interr.h" boolean internal_errors_enabled = 0; +boolean my_error_stuff_ok = 1; struct sigcontext *lisp_interrupt_contexts[MAX_INTERRUPTS]; @@ -56,10 +57,10 @@ static boolean maybe_gc_pending = FALSE; * Utility routines used by various signal handlers. * \****************************************************************/ -void fake_foreign_function_call(struct sigcontext *context) +void +fake_foreign_function_call(struct sigcontext *context) { int context_index; - lispobj oldcont; /* Get current LISP state from context */ #ifdef reg_ALLOC @@ -130,7 +131,8 @@ void fake_foreign_function_call(struct sigcontext *context) foreign_function_call_active = 1; } -void undo_fake_foreign_function_call(struct sigcontext *context) +void +undo_fake_foreign_function_call(struct sigcontext *context) { /* Block all blockable signals */ #ifdef POSIX_SIGS @@ -156,16 +158,21 @@ void undo_fake_foreign_function_call(struct sigcontext *context) #endif } -void interrupt_internal_error(HANDLER_ARGS, +void +interrupt_internal_error(HANDLER_ARGS, boolean continuable) { +#ifdef __linux__ + GET_CONTEXT +#endif + #ifdef POSIX_SIGS sigprocmask(SIG_SETMASK,&context->uc_sigmask, 0); #else sigsetmask(context->sc_mask); #endif fake_foreign_function_call(context); - if (internal_errors_enabled) + if (internal_errors_enabled && my_error_stuff_ok) funcall2(SymbolFunction(INTERNAL_ERROR), alloc_sap(context), continuable ? T : NIL); else @@ -175,7 +182,8 @@ void interrupt_internal_error(HANDLER_ARGS, arch_skip_instruction(context); } -void interrupt_handle_pending(struct sigcontext *context) +void +interrupt_handle_pending(struct sigcontext *context) { boolean were_in_lisp = !foreign_function_call_active; @@ -199,8 +207,12 @@ void interrupt_handle_pending(struct sigcontext *context) signal = pending_signal; code = pending_code; pending_signal = 0; - /* pending_code = 0; /**/ + /* pending_code = 0; */ +#ifdef __linux__ + interrupt_handle_now(signal,*context); +#else interrupt_handle_now(signal, PASSCODE(code), context); +#endif } #ifdef POSIX_SIGS context->uc_sigmask = pending_mask; @@ -217,10 +229,19 @@ void interrupt_handle_pending(struct sigcontext *context) * the two main signal handlers. * \****************************************************************/ -void interrupt_handle_now(HANDLER_ARGS) +void +interrupt_handle_now(HANDLER_ARGS) { +#ifdef __linux__ + GET_CONTEXT +#endif + int were_in_lisp; union interrupt_handler handler; + +#ifdef __linux__ + __setfpucw(contextstruct.fpstate->cw); +#endif handler = interrupt_handlers[signal]; @@ -254,14 +275,23 @@ void interrupt_handle_now(HANDLER_ARGS) alloc_sap(context)); #endif else +#ifdef __linux__ + (*handler.c)(signal, contextstruct); +#else (*handler.c)(signal, code, context); +#endif if (were_in_lisp) undo_fake_foreign_function_call(context); } -static void maybe_now_maybe_later(HANDLER_ARGS) +static void +maybe_now_maybe_later(HANDLER_ARGS) { +#ifdef __linux__ + GET_CONTEXT +#endif + SAVE_CONTEXT(); /**/ if (SymbolValue(INTERRUPTS_ENABLED) == NIL) { @@ -288,7 +318,11 @@ static void maybe_now_maybe_later(HANDLER_ARGS) #endif arch_set_pseudo_atomic_interrupted(context); } else +#ifdef __linux__ + interrupt_handle_now(signal,contextstruct); +#else interrupt_handle_now(signal, code, context); +#endif } /****************************************************************\ @@ -312,6 +346,10 @@ static boolean gc_trigger_hit(HANDLER_ARGS) boolean interrupt_maybe_gc(HANDLER_ARGS) { +#ifdef __linux__ + GET_CONTEXT +#endif + if (!foreign_function_call_active #ifndef INTERNAL_GC_TRIGGER && gc_trigger_hit(signal, code, context) @@ -362,16 +400,36 @@ void interrupt_install_low_level_handler sa.sa_flags = SA_RESTART | SA_SIGINFO; sigaction(signal, &sa, NULL); +#else +#if defined __FreeBSD__ && 0 /* hack in progress */ +/* sort of like POSIX -- maybe fixed in new release */ +#define FILLBLOCKSET(s) (sigaddset(s,SIGHUP), sigaddset(s,SIGINT), \ + sigaddset(s,SIGQUIT), sigaddset(s,SIGPIPE), \ + sigaddset(s,SIGALRM), sigaddset(s,SIGURG), \ + sigaddset(s,SIGTSTP), sigaddset(s,SIGCHLD), \ + sigaddset(s,SIGIO), sigaddset(s,SIGXCPU), \ + sigaddset(s,SIGXFSZ), sigaddset(s,SIGVTALRM), \ + sigaddset(s,SIGPROF), sigaddset(s,SIGWINCH), \ + sigaddset(s,SIGUSR1), sigaddset(s,SIGUSR2)) + + struct sigaction sa; + sa.sa_handler = handler; + sigemptyset(&sa.sa_mask); + FILLBLOCKSET(&sa.sa_mask); + sa.sa_flags = SA_RESTART | SA_SIGINFO; + sa.sa_flags |= SA_ONSTACK; #else struct sigvec sv; sv.sv_handler=handler; sv.sv_mask=BLOCKABLE; sv.sv_flags=0; - +#if defined USE_SIG_STACK + sv.sv_flags |= SV_ONSTACK; /* use separate stack */ +#endif sigvec(signal,&sv,NULL); #endif - +#endif interrupt_low_level_handlers[signal]=(handler==SIG_DFL ? 0 : handler); } @@ -430,7 +488,9 @@ unsigned long install_handler(int signal, sv.sv_mask = BLOCKABLE; sv.sv_flags = 0; - +#if defined USE_SIG_STACK + sv.sv_flags = SV_ONSTACK; +#endif sigvec(signal, &sv, NULL); } diff --git a/lisp/linux-stubs.S b/lisp/linux-stubs.S new file mode 100644 index 000000000..3af204f0e --- /dev/null +++ b/lisp/linux-stubs.S @@ -0,0 +1,171 @@ +/* linux-stubs.S + + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/linux-stubs.S,v 1.1 1997/01/21 00:28:13 ram Exp $ + + These are needed because the locations of the + libraries are filled in by ld.so at runtime. +*/ + + .file "linux-stubs.S" + .version "01.01" +gcc2_compiled.: +.text +#define doe(fct) \ + .align 16 ;\ +.globl PVE_stub_ ## fct ;\ + .type PVE_stub_ ## fct,@function ;\ +PVE_stub_ ## fct: ;\ + jmp fct ;\ +.L ## fct ## e1: ;\ + .size PVE_stub_ ## fct,.L ## fct ## e1-PVE_stub_ ## fct ; + + doe(malloc) + doe(free) + doe(isatty) + doe(accept) + doe(access) + doe(acct) + doe(adjtime) + doe(bind) + doe(brk) + doe(chdir) + doe(chmod) + doe(chown) + doe(chroot) + doe(close) + doe(connect) + doe(creat) + doe(dup) + doe(dup2) + doe(execve) + doe(exit) + doe(fchmod) + doe(fchown) + doe(fcntl) + doe(flock) + doe(fork) + doe(fstat) + doe(fsync) + doe(ftruncate) + doe(getdtablesize) + doe(getegid) + doe(geteuid) + doe(getgid) + doe(getgroups) + doe(gethostid) + doe(gethostname) + doe(getitimer) + doe(getpagesize) + doe(getpeername) + doe(getpgrp) + doe(getpid) + doe(getppid) + doe(getpriority) + doe(getrlimit) + doe(getrusage) + doe(getsockname) + doe(getsockopt) + doe(gettimeofday) + doe(getuid) + doe(ioctl) + doe(kill) + doe(killpg) + doe(link) + doe(listen) + doe(lseek) + doe(lstat) + doe(mkdir) + doe(mknod) + doe(mount) + doe(open) + doe(pipe) + doe(ptrace) + doe(read) + doe(readlink) + doe(readv) + doe(reboot) + doe(recv) + doe(recvfrom) + doe(recvmsg) + doe(rename) + doe(rmdir) + doe(sbrk) + doe(select) + doe(send) + doe(sendmsg) + doe(sendto) + doe(setgroups) + doe(sethostid) + doe(sethostname) + doe(setitimer) + doe(setpgrp) + doe(setpriority) + doe(setregid) + doe(setreuid) + doe(setrlimit) + doe(setsockopt) + doe(settimeofday) + doe(shutdown) + doe(sigblock) + doe(sigpause) + doe(sigreturn) + doe(sigsetmask) + doe(socket) + doe(socketpair) + doe(stat) + doe(swapon) + doe(symlink) + doe(sync) + doe(syscall) + doe(closedir) + doe(opendir) + doe(readdir) + doe(tcgetattr) + doe(tcsetattr) + doe(truncate) + doe(umask) + doe(umount) + doe(unlink) + doe(utimes) + doe(vfork) + doe(vhangup) + doe(wait) + doe(wait3) + doe(write) + doe(writev) + doe(cos) + doe(sin) + doe(tan) + doe(acos) + doe(asin) + doe(atan) + doe(atan2) + doe(sinh) + doe(cosh) + doe(tanh) + doe(asinh) + doe(acosh) + doe(atanh) + doe(exp) + doe(expm1) + doe(log) + doe(log10) + doe(log1p) + doe(pow) + doe(cbrt) + doe(sqrt) + doe(hypot) + doe(gethostbyname) + doe(gethostbyaddr) + doe(setpgid) + doe(getpgid) + doe(timezone) + doe(altzone) + doe(daylight) + doe(tzname) + doe(dlopen) + doe(dlsym) + doe(dlclose) + doe(dlerror) + doe(getwd) + doe(ttyname) diff --git a/lisp/lisp.c b/lisp/lisp.c index fff95e20f..a910102dc 100644 --- a/lisp/lisp.c +++ b/lisp/lisp.c @@ -1,7 +1,7 @@ /* * main() entry point for a stand alone lisp image. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lisp.c,v 1.10 1994/11/01 19:35:49 ram Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lisp.c,v 1.11 1997/01/21 00:28:13 ram Exp $ * */ @@ -39,9 +39,13 @@ static void sigint_handler(HANDLER_ARGS) { +#ifdef __linux__ + GET_CONTEXT +#endif + SAVE_CONTEXT(); - printf("\nSIGINT hit at 0x%08X\n", SC_PC(context)); + printf("\nSIGINT hit at 0x%08lX\n", SC_PC(context)); ldb_monitor(); } @@ -87,7 +91,7 @@ void main(int argc, char *argv[], char *envp[]) #ifdef MACH mach_init(); #endif -#ifdef SVR4 +#if defined(SVR4) || defined(__linux__) tzset(); #endif @@ -145,11 +149,15 @@ void main(int argc, char *argv[], char *envp[]) } if (core == NULL) { /* Note: the /usr/misc/.cmucl/lib/ default path is also wired - /* into the lisp code in .../code/save.lisp. */ + into the lisp code in .../code/save.lisp. */ #ifdef MACH strcpy(buf, "/usr/misc/.cmucl/lib/"); +#else +#ifdef __linux__ + strcpy(buf, "/usr/lib/cmucl/"); #else strcpy(buf, "/usr/local/lib/cmucl/lib/"); +#endif #endif strcat(buf, default_core); core = buf; @@ -163,10 +171,19 @@ void main(int argc, char *argv[], char *envp[]) initial_function = load_core_file(core); +#if defined WANT_CGC && defined X86_CGC_ACTIVE_P + { + extern int use_cgc_p; + lispobj x = SymbolValue(X86_CGC_ACTIVE_P); + if(x != type_UnboundMarker && x != NIL) + use_cgc_p = 1; /* enable allocator */ + } +#endif + #ifdef BINDING_STACK_POINTER SetSymbolValue(BINDING_STACK_POINTER, (lispobj)binding_stack); #endif -#ifdef INTERNAL_GC_TRIGGER +#if defined INTERNAL_GC_TRIGGER && !defined i386 SetSymbolValue(INTERNAL_GC_TRIGGER, fixnum(-1)); #endif diff --git a/lisp/lisp.h b/lisp/lisp.h index a30b9b8c7..ecd37773f 100644 --- a/lisp/lisp.h +++ b/lisp/lisp.h @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lisp.h,v 1.2 1994/03/27 15:27:35 hallgren Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lisp.h,v 1.3 1997/01/21 00:28:13 ram Exp $ */ #ifndef _LISP_H_ #define _LISP_H_ @@ -18,8 +18,14 @@ #define SYMBOL(obj) ((struct symbol *)((obj)-type_OtherPointer)) #define FDEFN(obj) ((struct fdefn *)((obj)-type_OtherPointer)) -#ifndef alpha +#if !defined alpha typedef unsigned long lispobj; + +#if defined(__FreeBSD__) || defined(__linux__) +typedef unsigned int u32; +typedef signed int s32; +#endif + #else typedef unsigned int u32; typedef signed int s32; diff --git a/lisp/monitor.c b/lisp/monitor.c index 767a34217..ba7de0f10 100644 --- a/lisp/monitor.c +++ b/lisp/monitor.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/monitor.c,v 1.5 1994/10/24 20:06:50 ram Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/monitor.c,v 1.6 1997/01/21 00:28:13 ram Exp $ */ #include <stdio.h> #include <sys/types.h> @@ -102,7 +102,7 @@ static void dump_cmd(char **ptr) while (count-- > 0) { #ifndef alpha - printf("0x%08X: ", (unsigned long) addr); + printf("0x%08lX: ", (unsigned long) addr); #else printf("0x%08X: ", (u32) addr); #endif @@ -115,7 +115,7 @@ static void dump_cmd(char **ptr) unsigned short *sptr = (unsigned short *)addr; unsigned char *cptr = (unsigned char *)addr; - printf("0x%08x 0x%04x 0x%04x 0x%02x 0x%02x 0x%02x 0x%02x %c%c%c%c\n", lptr[0], sptr[0], sptr[1], cptr[0], cptr[1], cptr[2], cptr[3], visable(cptr[0]), visable(cptr[1]), visable(cptr[2]), visable(cptr[3])); + printf("0x%08lx 0x%04x 0x%04x 0x%02x 0x%02x 0x%02x 0x%02x %c%c%c%c\n", lptr[0], sptr[0], sptr[1], cptr[0], cptr[1], cptr[2], cptr[3], visable(cptr[0]), visable(cptr[1]), visable(cptr[2]), visable(cptr[3])); } else printf("invalid address\n"); @@ -135,23 +135,26 @@ static void print_cmd(char **ptr) static void regs_cmd(char **ptr) { - printf("CSP\t=\t0x%08X\n", (unsigned long)current_control_stack_pointer); - printf("FP\t=\t0x%08X\n", (unsigned long)current_control_frame_pointer); -#ifndef ibmrt + printf("CSP\t=\t0x%08lX\n", (unsigned long)current_control_stack_pointer); + printf("FP\t=\t0x%08lX\n", (unsigned long)current_control_frame_pointer); +#if !defined(ibmrt) && !defined(i386) printf("BSP\t=\t0x%08X\n", (unsigned long)current_binding_stack_pointer); #endif +#ifdef i386 + printf("BSP\t=\t0x%08X\n", SymbolValue(BINDING_STACK_POINTER)); +#endif - printf("DYNAMIC\t=\t0x%08X\n", (unsigned long)current_dynamic_space); -#ifdef ibmrt - printf("ALLOC\t=\t0x08X\n", SymbolValue(ALLOCATION_POINTER)); - printf("TRIGGER\t=\t0x08X\n", SymbolValue(INTERNAL_GC_TRIGGER)); + printf("DYNAMIC\t=\t0x%08lX\n", (unsigned long)current_dynamic_space); +#if defined(ibmrt) || defined(i386) + printf("ALLOC\t=\t0x%08lX\n", SymbolValue(ALLOCATION_POINTER)); + printf("TRIGGER\t=\t0x%08lX\n", SymbolValue(INTERNAL_GC_TRIGGER)); #else printf("ALLOC\t=\t0x%08X\n", (unsigned long)current_dynamic_space_free_pointer); printf("TRIGGER\t=\t0x%08X\n", (unsigned long)current_auto_gc_trigger); #endif - printf("STATIC\t=\t0x%08X\n", SymbolValue(STATIC_SPACE_FREE_POINTER)); - printf("RDONLY\t=\t0x%08X\n", SymbolValue(READ_ONLY_SPACE_FREE_POINTER)); + printf("STATIC\t=\t0x%08lX\n", SymbolValue(STATIC_SPACE_FREE_POINTER)); + printf("RDONLY\t=\t0x%08lX\n", SymbolValue(READ_ONLY_SPACE_FREE_POINTER)); #ifdef MIPS printf("FLAGS\t=\t0x%08x\n", current_flags_register); @@ -198,10 +201,10 @@ static void search_cmd(char **ptr) start = end = addr; lastcount = count; - printf("searching for 0x%x at 0x%08X\n", val, (unsigned long)end); + printf("searching for 0x%x at 0x%08lX\n", val, (unsigned long)end); while (search_for_type(val, &end, &count)) { - printf("found 0x%x at 0x%08X:\n", val, (unsigned long)end); + printf("found 0x%x at 0x%08lX:\n", val, (unsigned long)end); obj = *end; addr = end; end += 2; @@ -232,26 +235,26 @@ static void call_cmd(char **ptr) goto fdefn; } } - printf("symbol 0x%08x is undefined.\n", thing); + printf("symbol 0x%08lx is undefined.\n", thing); return; case type_Fdefn: fdefn: function = FDEFN(thing)->function; if (function == NIL) { - printf("fdefn 0x%08x is undefined.\n", thing); + printf("fdefn 0x%08lx is undefined.\n", thing); return; } break; default: printf( - "0x%08x is not a function pointer, symbol, or fdefn object.\n", + "0x%08lx is not a function pointer, symbol, or fdefn object.\n", thing); return; } } else if (LowtagOf(thing) != type_FunctionPointer) { - printf("0x%08x is not a function pointer, symbol, or fdefn object.\n", + printf("0x%08lx is not a function pointer, symbol, or fdefn object.\n", thing); return; } @@ -335,7 +338,7 @@ static void print_context(struct sigcontext *context) printf("%s:\t", lisp_register_names[i]); brief_print((lispobj) SC_REG(context, i)); } - printf("PC:\t\t 0x%08x\n", SC_PC(context)); + printf("PC:\t\t 0x%08lx\n", SC_PC(context)); } static void print_context_cmd(char **ptr) @@ -392,7 +395,7 @@ static void catchers_cmd(char **ptr) printf("There are no active catchers!\n"); else { while (catch != NULL) { - printf("0x%08X:\n\tuwp: 0x%08X\n\tfp: 0x%08X\n\tcode: 0x%08x\n\tentry: 0x%08x\n\ttag: ", (unsigned long)catch, (unsigned long)(catch->current_uwp), (unsigned long)(catch->current_cont), catch->current_code, catch->entry_pc); + printf("0x%08lX:\n\tuwp: 0x%08lX\n\tfp: 0x%08lX\n\tcode: 0x%08lx\n\tentry: 0x%08lx\n\ttag: ", (unsigned long)catch, (unsigned long)(catch->current_uwp), (unsigned long)(catch->current_cont), catch->current_code, catch->entry_pc); brief_print((lispobj)catch->tag); catch = catch->previous_catch; } diff --git a/lisp/os.h b/lisp/os.h index 8df4af639..84c120f12 100644 --- a/lisp/os.h +++ b/lisp/os.h @@ -1,5 +1,5 @@ /* - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/os.h,v 1.5 1994/10/25 00:11:29 ram Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/os.h,v 1.6 1997/01/21 00:28:13 ram Exp $ * * Common interface for os-dependent functions. * @@ -25,6 +25,14 @@ #else #ifdef irix #include "irix-os.h" +#else +#ifdef __FreeBSD__ +#include "FreeBSD-os.h" +#else +#ifdef __linux__ +#include "Linux-os.h" +#endif +#endif #endif #endif #endif diff --git a/lisp/parse.c b/lisp/parse.c index 67762a13a..f33449a6c 100644 --- a/lisp/parse.c +++ b/lisp/parse.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/parse.c,v 1.2 1994/10/25 00:09:21 ram Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/parse.c,v 1.3 1997/01/21 00:28:13 ram Exp $ */ #include <stdio.h> #include <ctype.h> #include <signal.h> @@ -15,7 +15,7 @@ #include "arch.h" #include "search.h" -#if !defined(MACH) && !defined(SVR4) +#if !defined(MACH) && !defined(SVR4) && !defined(__linux__) static int strcasecmp(s1,s2) char *s1,*s2; @@ -234,8 +234,8 @@ char **ptr; result &= ~3; } - if (!valid_addr(result)) { - printf("Invalid address: 0x%x\n", result); + if (!valid_addr((os_vm_address_t)result)) { + printf("Invalid address: 0x%lx\n", result); throw_to_monitor(); } @@ -258,7 +258,7 @@ static boolean lookup_symbol(char *name, lispobj *result) /* Search dynamic space */ headerptr = current_dynamic_space; -#ifndef ibmrt +#if !defined(ibmrt) && !defined(i386) count = current_dynamic_space_free_pointer - current_dynamic_space; #else count = (lispobj *)SymbolValue(ALLOCATION_POINTER) - current_dynamic_space; @@ -336,7 +336,7 @@ char **ptr; } else if (token[0] == '@') { if (string_to_long(token+1, &pointer)) { pointer &= ~3; - if (valid_addr(pointer)) + if (valid_addr((os_vm_address_t)pointer)) result = *(lispobj *)pointer; else { printf("Invalid address: ``%s''\n", token+1); diff --git a/lisp/print.c b/lisp/print.c index 5cb9211da..b9c858e5b 100644 --- a/lisp/print.c +++ b/lisp/print.c @@ -1,4 +1,4 @@ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/print.c,v 1.3 1994/03/27 15:18:07 hallgren Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/print.c,v 1.4 1997/01/21 00:28:13 ram Exp $ */ #include <stdio.h> #include "print.h" @@ -125,7 +125,7 @@ static void newline(char *label) static void brief_fixnum(lispobj obj) { #ifndef alpha - printf("%d", ((long)obj)>>2); + printf("%ld", ((long)obj)>>2); #else printf("%d", ((s32)obj)>>2); #endif @@ -134,7 +134,7 @@ static void brief_fixnum(lispobj obj) static void print_fixnum(lispobj obj) { #ifndef alpha - printf(": %d", ((long)obj)>>2); + printf(": %ld", ((long)obj)>>2); #else printf(": %d", ((s32)obj)>>2); #endif @@ -214,7 +214,7 @@ static void print_otherimm(lispobj obj) break; default: - printf(": data=%d", (obj>>8)&0xffffff); + printf(": data=%ld", (obj>>8)&0xffffff); break; } } @@ -224,7 +224,7 @@ static void brief_list(lispobj obj) int space = FALSE; int length = 0; - if (!valid_addr(obj)) + if (!valid_addr((os_vm_address_t)obj)) printf("(invalid address)"); else if (obj == NIL) printf("NIL"); @@ -256,7 +256,7 @@ static void brief_list(lispobj obj) static void print_list(lispobj obj) { - if (!valid_addr(obj)) + if (!valid_addr((os_vm_address_t)obj)) printf("(invalid address)"); else if (obj == NIL) printf(" (NIL)"); @@ -270,7 +270,7 @@ static void print_list(lispobj obj) static void brief_struct(lispobj obj) { - printf("#<ptr to 0x%08x instance>", + printf("#<ptr to 0x%08lx instance>", ((struct instance *)PTR(obj))->slots[0]); } @@ -296,7 +296,7 @@ static void brief_otherptr(lispobj obj) ptr = (lispobj *) PTR(obj); - if (!valid_addr(obj)) { + if (!valid_addr((os_vm_address_t)obj)) { printf("(invalid address)"); return; } @@ -353,7 +353,7 @@ static char *fdefn_slots[] = {"name: ", "function: ", "raw_addr: ", NULL}; static void print_otherptr(lispobj obj) { - if (!valid_addr(obj)) + if (!valid_addr((os_vm_address_t)obj)) printf("(invalid address)"); else { #ifndef alpha @@ -392,7 +392,7 @@ static void print_otherptr(lispobj obj) NEWLINE; printf("0x"); while (count-- > 0) - printf("%08x", *--ptr); + printf("%08lx", *--ptr); break; case type_Ratio: @@ -409,12 +409,12 @@ static void print_otherptr(lispobj obj) case type_SingleFloat: NEWLINE; - printf("%f", ((struct single_float *)PTR(obj))->value); + printf("%g", ((struct single_float *)PTR(obj))->value); break; case type_DoubleFloat: NEWLINE; - printf("%f", ((struct double_float *)PTR(obj))->value); + printf("%g", ((struct double_float *)PTR(obj))->value); break; case type_SimpleString: @@ -429,7 +429,7 @@ static void print_otherptr(lispobj obj) case type_SimpleVector: case type_InstanceHeader: NEWLINE; - printf("length = %d", length); + printf("length = %ld", length); ptr++; index = 0; while (length-- > 0) { @@ -473,7 +473,7 @@ static void print_otherptr(lispobj obj) case type_Sap: NEWLINE; #ifndef alpha - printf("0x%08x", *ptr); + printf("0x%08lx", *ptr); #else printf("0x%016lx", *(long*)(ptr+1)); #endif @@ -535,7 +535,7 @@ static void print_obj(char *prefix, lispobj obj) } else newline(NULL); - printf("%s0x%08x: ", prefix, obj); + printf("%s0x%08lx: ", prefix, obj); if (cur_depth < brief_depth) { fputs(lowtag_Names[type], stdout); (*verbose_fns[type])(obj); diff --git a/lisp/purify.c b/lisp/purify.c index 70f629c89..687686a70 100644 --- a/lisp/purify.c +++ b/lisp/purify.c @@ -1,7 +1,11 @@ /* Purify. */ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.6 1993/03/29 03:39:58 wlott Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.7 1997/01/21 00:28:13 ram Exp $ */ +/* This file has been hacked a bunch by Werkowski as part of + * the x86 port. Stack direction changes as well as more conservative + * decisions about pointers. It probably doesn't work yet. + */ #include <stdio.h> #include <sys/types.h> #include <stdlib.h> @@ -15,10 +19,16 @@ #include "purify.h" #include "interr.h" +#undef PRINTNOISE + +#if defined(ibmrt) || defined(i386) +static lispobj *current_dynamic_space_free_pointer; +#endif + #define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \ __FILE__, __LINE__) -#if 0 +#if 1 #define gc_assert(ex) do { \ if (!(ex)) gc_abort(); \ } while (0) @@ -26,7 +36,7 @@ #define gc_assert(ex) #endif - + /* These hold the original end of the read_only and static spaces so we can */ /* tell what are forwarding pointers. */ @@ -55,8 +65,9 @@ static int later_count = 0; #else #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer) #endif - -static boolean forwarding_pointer_p(lispobj obj) + +static boolean +forwarding_pointer_p(lispobj obj) { lispobj *ptr; @@ -66,12 +77,92 @@ static boolean forwarding_pointer_p(lispobj obj) (read_only_end <= ptr && ptr <= read_only_free)); } -static boolean dynamic_pointer_p(lispobj ptr) +static boolean +dynamic_pointer_p(lispobj ptr) { - return ptr >= (lispobj)dynamic_0_space; +#ifndef i386 + return (ptr >= (lispobj)dynamic_0_space); +#else + /* Be more conservative, and remember, this is a maybe */ + return (ptr >= (lispobj)current_dynamic_space + && + ptr < (lispobj)current_dynamic_space_free_pointer); +#endif } - -static void pscav_later(lispobj *where, int count) + +static int +maybe_can_move_p(lispobj thing) +{ + lispobj *thingp,header; + if (dynamic_pointer_p(thing)) { /* in dynamic space */ + thingp = (lispobj*)PTR(thing); + header = *thingp; + if(Pointerp(header) && forwarding_pointer_p(header)) + return -1; /* must change it */ + if(LowtagOf(thing) == type_ListPointer) + return type_ListPointer; /* can we check this somehow */ + else if (thing & 3) { /* not fixnum */ + int kind = TypeOf(header); + /* printf(" %x %x",header,kind); */ + switch (kind) { /* something with a header */ + case type_Bignum: + case type_SingleFloat: + case type_DoubleFloat: + case type_Sap: + case type_SimpleVector: + case type_SimpleString: + case type_SimpleBitVector: + case type_SimpleArrayUnsignedByte2: + case type_SimpleArrayUnsignedByte4: + case type_SimpleArrayUnsignedByte8: + case type_SimpleArrayUnsignedByte16: + case type_SimpleArrayUnsignedByte32: + case type_SimpleArraySingleFloat: + case type_SimpleArrayDoubleFloat: + case type_CodeHeader: + case type_FunctionHeader: + case type_ClosureFunctionHeader: + case type_ReturnPcHeader: + case type_ClosureHeader: + case type_FuncallableInstanceHeader: + case type_InstanceHeader: + case type_ValueCellHeader: + case type_ByteCodeFunction: + case type_ByteCodeClosure: + case type_DylanFunctionHeader: + case type_WeakPointer: + case type_Fdefn: + return kind; + break; + default: + return 0; + }}} + return 0; +} + +static int pverbose=0; +#define PVERBOSE pverbose +static void +carefully_pscav_stack(lispobj*lowaddr, lispobj*base) +{ + lispobj*sp = lowaddr; + while(sp < base) + { int k; + lispobj thing = *sp; + if((unsigned)thing & 0x3) /* may be pointer */ + { + /* need to check for valid float/double? */ + k = maybe_can_move_p(thing); + if(PVERBOSE)printf("%8x %8x %d\n",sp, thing, k); + if(k) + pscav(sp, 1, FALSE); + } + sp++; + } +} + +static void +pscav_later(lispobj *where, int count) { struct later *new; @@ -234,6 +325,13 @@ static lispobj ptrans_code(lispobj thing) code = (struct code *)PTR(thing); nwords = HeaderValue(code->header) + fixnum_value(code->code_size); + /* Moving machine code around does not work on the x86 port, but + byte compiled function code blocks can be moved. Perhaps for + all byte compiled code blocks the entry_points slot is nil. + Check and print a warning. */ + if ( (code->entry_points) != NIL ) + fprintf(stderr,"** ptrans_code(%x)\n",thing); + new = (struct code *)read_only_free; read_only_free += CEILING(nwords, 2); @@ -257,6 +355,13 @@ static lispobj ptrans_code(lispobj thing) /* Arrange to scavenge the debug info later. */ pscav_later(&new->debug_info, 1); + if(new->trace_table_offset & 0x3) +#if 0 + pscav(&new->trace_table_offset, 1, FALSE); +#else + new->trace_table_offset = NIL; /* limit lifetime */ +#endif + /* Scavenge the constants. */ pscav(new->constants, HeaderValue(new->header)-5, TRUE); @@ -289,6 +394,10 @@ static lispobj ptrans_func(lispobj thing, lispobj header) if (TypeOf(header) == type_FunctionHeader || TypeOf(header) == type_ClosureFunctionHeader) { + /* Moving code around is not good on the x86 port; print a + warning. */ + fprintf(stderr,"ptrans_function(%x, %x)\n",thing,header); + /* We can only end up here if the code object has not been */ /* scavenged, because if it had been scavenged, forwarding pointers */ /* would have been left behind for all the entry points. */ @@ -318,10 +427,10 @@ static lispobj ptrans_func(lispobj thing, lispobj header) else { /* Closures can always go in read-only space, 'caues */ /* they never change. */ + new = read_only_free; read_only_free += CEILING(nwords, 2); } - /* Copy it. */ bcopy(old, new, nwords * sizeof(lispobj)); @@ -479,16 +588,49 @@ static int pscav_fdefn(struct fdefn *fdefn) } #ifdef i386 -static int pscav_closure_header(closure) - struct closure *closure; +/* now putting code objects in static space */ +static int +pscav_code(struct code*code) { - lispobj fun = closure->function - RAW_ADDR_OFFSET; - int nwords = HeaderValue(closure->header); + int nwords; + lispobj func; + nwords = HeaderValue(code->header) + fixnum_value(code->code_size); + - pscav(&fun, 1, TRUE); - pscav(closure->info, nwords-1, TRUE); - return nwords+1; + /* pw--The trace_table_offset slot can contain a list pointer. This + * occurs when the code object is a top level form that initializes + * a byte-compiled function. The fact that purify was ignoring this + * slot may be a bug unrelated to the x86 port, except that TLF's + * normally become unreachable after the loader calls them and + * won't be seen by purify at all!! + */ + if(code->trace_table_offset & 0x3) +#if 0 + pscav(&code->trace_table_offset, 1, FALSE); +#else + code->trace_table_offset = NIL; /* limit lifetime */ +#endif + + /* Arrange to scavenge the debug info later. */ + pscav_later(&code->debug_info, 1); + + /* Scavenge the constants. */ + pscav(code->constants, HeaderValue(code->header)-5, TRUE); + + /* Scavenge all the functions. */ + pscav(&code->entry_points, 1, TRUE); + for (func = code->entry_points; + func != NIL; + func = ((struct function *)PTR(func))->next) { + gc_assert(LowtagOf(func) == type_FunctionPointer); + gc_assert(!dynamic_pointer_p(func)); + pscav(&((struct function *)PTR(func))->self, 2, TRUE); + pscav_later(&((struct function *)PTR(func))->name, 3); + } + + return CEILING(nwords,2); } + #endif static lispobj *pscav(lispobj *addr, int nwords, boolean constant) @@ -601,23 +743,38 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant) break; case type_CodeHeader: +#ifndef i386 gc_abort(); /* No code headers in static space */ +#else + count = pscav_code((struct code*)addr); +#endif break; case type_FunctionHeader: case type_ClosureFunctionHeader: case type_ReturnPcHeader: - /* We should never hit any of these, 'cause they occure */ + /* We should never hit any of these, 'cause they occur */ /* buried in the middle of code objects. */ + gc_abort(); + + break; + #ifdef i386 case type_ClosureHeader: case type_FuncallableInstanceHeader: case type_ByteCodeFunction: case type_ByteCodeClosure: case type_DylanFunctionHeader: - count = pscav_closure_header((struct closure *)addr); + /* The function self pointer needs special care on the + x86 because it is the real entry point. */ + { + lispobj fun = ((struct closure *)addr)->function + - RAW_ADDR_OFFSET; + pscav(&fun, 1, constant); + } + count = 2; break; #endif @@ -668,6 +825,11 @@ int purify(lispobj static_roots, lispobj read_only_roots) return 0; } +#if defined(ibmrt) || defined(i386) + current_dynamic_space_free_pointer = + (lispobj*)SymbolValue(ALLOCATION_POINTER); +#endif + read_only_end = read_only_free = (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER); static_end = static_free = @@ -692,13 +854,18 @@ int purify(lispobj static_roots, lispobj read_only_roots) printf(" stack"); fflush(stdout); #endif +#ifndef i386 pscav(control_stack, current_control_stack_pointer - control_stack, FALSE); +#else + gc_assert(control_stack_end > ((&read_only_roots)+1)); + carefully_pscav_stack(((&read_only_roots)+1), control_stack_end); +#endif #ifdef PRINTNOISE printf(" bindings"); fflush(stdout); #endif -#ifndef ibmrt +#if !defined(ibmrt) && !defined(i386) pscav(binding_stack, current_binding_stack_pointer - binding_stack, FALSE); #else pscav(binding_stack, (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack, FALSE); @@ -739,22 +906,65 @@ int purify(lispobj static_roots, lispobj read_only_roots) printf(" cleanup"); fflush(stdout); #endif + +/* well, something seems messed up in FreeBSD VM, hacking to resolve it. + * Nope -- problem was 'auto-gc-trigger' mprotecting pages in background. + */ +#if defined X86_CGC_ACTIVE_P + if(SymbolValue(X86_CGC_ACTIVE_P) != T) + os_zero((os_vm_address_t) current_dynamic_space, + (os_vm_size_t) DYNAMIC_SPACE_SIZE); +#else os_zero((os_vm_address_t) current_dynamic_space, (os_vm_size_t) DYNAMIC_SPACE_SIZE); - +#endif /* Zero stack. */ +#ifndef i386 os_zero((os_vm_address_t) current_control_stack_pointer, (os_vm_size_t) (CONTROL_STACK_SIZE - ((current_control_stack_pointer - control_stack) * sizeof(lispobj)))); +#else + /* os_zero won't work cause it things the junk is above the + * start address where here it is below. I don't see why we want + * to zero stuff anyhow. + */ +#endif -#ifndef ibmrt +#if defined STATIC_BLUE_BAG + { + lispobj bag = SymbolValue(STATIC_BLUE_BAG); + struct cons*cons = (struct cons*)static_free; + struct cons*pair = cons + 1; + static_free += 2*WORDS_PER_CONS; + if(bag == type_UnboundMarker) + bag = NIL; + cons->cdr = bag; + cons->car = (lispobj)pair | type_ListPointer; + pair->car = (lispobj)static_end; + pair->cdr = (lispobj)static_free; + bag = (lispobj)cons | type_ListPointer; + SetSymbolValue(STATIC_BLUE_BAG, bag); + } +#endif + + /* It helps to update the heap free pointers so that free_heap can + verify after it's done. */ + SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free); + SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free); + +#if !defined(ibmrt) && !defined(i386) current_dynamic_space_free_pointer = current_dynamic_space; +#endif + +#if defined X86_CGC_ACTIVE_P + if(SymbolValue(X86_CGC_ACTIVE_P) != T) + SetSymbolValue(ALLOCATION_POINTER, (lispobj)current_dynamic_space); + else + cgc_free_heap(); #else SetSymbolValue(ALLOCATION_POINTER, (lispobj)current_dynamic_space); #endif - SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free); - SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free); #ifdef PRINTNOISE printf(" Done.]\n"); diff --git a/lisp/save.c b/lisp/save.c index c9630c12b..d40261ad1 100644 --- a/lisp/save.c +++ b/lisp/save.c @@ -1,6 +1,6 @@ /* - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/save.c,v 1.4 1994/10/27 17:13:54 ram Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/save.c,v 1.5 1997/01/21 00:28:13 ram Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -75,7 +75,26 @@ static void output_space(FILE *file, int id, lispobj *addr, lispobj *end) boolean save(char *filename, lispobj init_function) { FILE *file; - +#if defined WANT_CGC + volatile lispobj*func_ptr = &init_function; + char sbuf[128]; + strcpy(sbuf,filename); + filename=sbuf; + /* Get rid of remnant stuff. This is a MUST so that + * the memory manager can get started correctly when + * we restart after this save. Purify is going to + * maybe move the args so we need to consider them volatile, + * especially if the gcc optimizer is working!! + */ + purify(NIL,NIL); + + init_function = *func_ptr; + /* Set dynamic space pointer to base value so we don't write out + * MBs of just cleared heap. + */ + if(SymbolValue(X86_CGC_ACTIVE_P) != NIL) + SetSymbolValue(ALLOCATION_POINTER,DYNAMIC_0_SPACE_START); +#endif /* Open the file: */ unlink(filename); file = fopen(filename, "w"); @@ -90,7 +109,9 @@ boolean save(char *filename, lispobj init_function) SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0); SetSymbolValue(EVAL_STACK_TOP, 0); printf("done]\n"); - +#if defined WANT_CGC && defined X86_CGC_ACTIVE_P + SetSymbolValue(X86_CGC_ACTIVE_P, T); +#endif printf("[Saving current lisp image into %s:\n", filename); putw(CORE_MAGIC, file); diff --git a/lisp/undefineds.h b/lisp/undefineds.h index 9c5ec9acb..c98a25794 100644 --- a/lisp/undefineds.h +++ b/lisp/undefineds.h @@ -1,5 +1,5 @@ /* Routines that must be linked into the core for lisp to work. */ -/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/undefineds.h,v 1.8 1994/10/30 21:43:03 ram Exp $ */ +/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/undefineds.h,v 1.9 1997/01/21 00:28:13 ram Exp $ */ /* Pick up all the syscalls. */ accept, @@ -75,7 +75,9 @@ mknod, mount, open, pipe, +#ifndef __linux__ profil, +#endif ptrace, #ifdef mach quota, @@ -123,14 +125,16 @@ shutdown, sigblock, #endif sigpause, -#if !defined(ibmrt) && !defined(hpux) && !defined(SVR4) +#if !defined(ibmrt) && !defined(hpux) && !defined(SVR4) && !defined(i386) sigreturn, #endif -#ifndef SVR4 +#if !defined SVR4 && !defined __FreeBSD__ sigsetmask, +#ifndef __linux__ sigstack, sigvec, #endif +#endif socket, socketpair, stat, @@ -140,7 +144,7 @@ swapon, symlink, sync, syscall, -#if defined(hpux) || defined(SVR4) +#if defined(__linux__) || defined(hpux) || defined(SVR4) closedir, opendir, readdir, @@ -149,7 +153,8 @@ tcsetattr, #endif truncate, umask, -#if !defined(SUNOS) && !defined(parisc) && !defined(SOLARIS) +#if !defined(SUNOS) && !defined(parisc) && !defined(SOLARIS) \ + && !defined(__FreeBSD__) umount, #endif unlink, @@ -159,7 +164,7 @@ utimes, #ifndef irix vfork, #endif -#ifndef osf1 +#if !defined osf1 && !defined __FreeBSD__ vhangup, #endif wait, @@ -170,8 +175,10 @@ write, writev, /* Math routines. */ +#ifndef i386 cos, sin, +#endif tan, acos, asin, @@ -198,7 +205,9 @@ pow, #ifndef hpux cbrt, #endif +#ifndef i386 sqrt, +#endif hypot, /* Network support. */ @@ -206,18 +215,20 @@ gethostbyname, gethostbyaddr, /* Other random things. */ -#ifdef SVR4 +#if defined(SVR4) || defined(__linux__) setpgid, getpgid, timezone, altzone, daylight, tzname, +#ifndef __linux__ dlopen, dlsym, dlclose, dlerror, #endif +#endif #ifndef SOLARIS getwd, #endif diff --git a/lisp/validate.c b/lisp/validate.c index e931de6a2..f113fcd06 100644 --- a/lisp/validate.c +++ b/lisp/validate.c @@ -1,5 +1,5 @@ /* - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/validate.c,v 1.4 1993/04/28 01:58:43 wlott Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/validate.c,v 1.5 1997/01/21 00:28:13 ram Exp $ * * Memory Validation */ @@ -69,6 +69,10 @@ void validate(void) /* Control Stack */ control_stack = (lispobj *) CONTROL_STACK_START; +#ifdef i386 + control_stack_end = (lispobj *) (CONTROL_STACK_START + + CONTROL_STACK_SIZE); +#endif ensure_space(control_stack, CONTROL_STACK_SIZE); /* Binding Stack */ diff --git a/lisp/x86-arch.c b/lisp/x86-arch.c new file mode 100644 index 000000000..33191950f --- /dev/null +++ b/lisp/x86-arch.c @@ -0,0 +1,329 @@ +/* x86-arch.c -*- Mode: C; comment-column: 40 -*- + * + * $header: $ + * + */ + +#include <stdio.h> + +#include "lisp.h" +#include "globals.h" +#include "validate.h" +#include "os.h" +#include "internals.h" +#include "arch.h" +#include "lispregs.h" +#include "signal.h" +#include "alloc.h" +#include "interrupt.h" +#include "interr.h" +#include "breakpoint.h" + +#define DPRINTF(test,e){if(test) fprintf e ;} + +#define BREAKPOINT_INST 0xcc /* INT3 */ + +char * +arch_init(void) +{ + return "lisp.core"; +} + +os_vm_address_t +arch_get_bad_addr(HANDLER_ARGS) +{ +#ifdef __linux__ + GET_CONTEXT +#endif + + unsigned int badinst; + + if((context->sc_pc & 3) != 0) return NULL; + + if( (context->sc_pc < READ_ONLY_SPACE_START || + context->sc_pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) && + ((lispobj *)context->sc_pc < current_dynamic_space || + (lispobj *)context->sc_pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE)) + return NULL; + + badinst = *(unsigned int *)context->sc_pc; +#ifdef fixme + if((badinst>>27)!=0x16) return NULL; + return (os_vm_address_t)(context->sc_regs[(badinst>>16)&0x1f]+(badinst&0xffff)); +#else + return NULL; +#endif +} + +void arch_skip_instruction(context) +struct sigcontext *context; +{ + /* Assuming we get here via an INT3 xxx instruction, the PC now + * points to the interrupt code (lisp value) so we just move past + * it. Skip the code, then if the code if an error-trap or + * Cerror-trap then skip the data bytes that follow. */ + int vlen,code; + + DPRINTF(0,(stderr,"[arch_skip_inst at %x>]\n", context->sc_pc)); + + /* Get and skip the lisp error code. */ + code = *(char*)context->sc_pc++; + switch (code) + { + case trap_Error: + case trap_Cerror: + /* Lisp error arg vector length */ + vlen = *(char*)context->sc_pc++; + /* Skip lisp error arg data bytes */ + while(vlen-- > 0) + (char*)context->sc_pc++; + /* Align 2 */ + /* (char*)context->sc_pc += 0x3; + context->sc_pc &= ~0x03; */ + break; + + case trap_Breakpoint: /* Not tested */ + case trap_FunctionEndBreakpoint: /* not tested */ + break; + + case trap_PendingInterrupt: + case trap_Halt: + /* Only needed to skip the Code. */ + break; + + default: + DPRINTF(1,(stderr,"[arch_skip_inst invalid code %d\n]\n",code)); + break; + } + + DPRINTF(0,(stderr,"[arch_skip_inst resuming at %x>]\n", context->sc_pc)); +} + +unsigned char * +arch_internal_error_arguments(struct sigcontext *context) +{ + return (unsigned char *)(context->sc_pc+1); +} + +boolean +arch_pseudo_atomic_atomic(struct sigcontext *context) +{ +#ifdef fixme + return (context->sc_regs[reg_ALLOC] & 1); +#else + return 0; +#endif +} + +#define PSEUDO_ATOMIC_INTERRUPTED_BIAS 0x7f000000 + +void +arch_set_pseudo_atomic_interrupted(struct sigcontext *context) +{ +#ifdef fixme + context->sc_regs[reg_ALLOC] |= 2; +#endif +} + +/* This stuff seems to get called for TRACE and debug activity */ +unsigned long +arch_install_breakpoint(void *pc) +{ + char*ptr = (char*)pc; + unsigned long result = *(unsigned long*)ptr; + *ptr++ = BREAKPOINT_INST; /* x86 INT3 */ + *ptr++ = trap_Breakpoint; /* Lisp trap code */ + *ptr++ = 1; /* vector length */ + *ptr++ = 0; /* junk data */ + + os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long)); + + return result; +} + +void +arch_remove_breakpoint(void *pc, unsigned long orig_inst) +{ + unsigned int *ptr=(unsigned int*)pc; + *ptr = orig_inst; + os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long)); +} + +static unsigned int *skipped_break_addr, displaced_after_inst, + after_breakpoint; +static int orig_sigmask; + +unsigned int +emulate_branch(struct sigcontext *context,unsigned long orig_inst) +{ + /* This has to be invented for the X86. Maybe figure out how + * to use the trace trap. Shouldn't be hard. Gdb does it. + */ + int next_pc = context->sc_pc; + return next_pc; +} + +#ifdef __linux__ +_syscall1(int,sigreturn,struct sigcontext *,context) +#endif + + +void +arch_do_displaced_inst(struct sigcontext *context, + unsigned long orig_inst) +{ + /* Ditto the above for X86. + */ + unsigned int *pc = (unsigned int*)context->sc_pc; + unsigned int *next_pc; + unsigned int next_inst; + DPRINTF(0,(stderr,"[arch_do_displaced_inst %x %x NOT YET!]\n", + context,orig_inst)); + sigreturn(context); +} + +#define AfterBreakpoint 100 /* pfw - what is this?? */ + +void +sigtrap_handler(HANDLER_ARGS) +{ +#ifdef __linux__ + GET_CONTEXT +#endif + + /* Don't disallow recursive breakpoint traps. Otherwise, we can't */ + /* use debugger breakpoints anywhere in here. */ + /*fprintf(stderr,"x86sigtrap: %8x %x\n", context->sc_pc, *(char*)(context->sc_pc-1)); + */ + DPRINTF(0,(stderr,"sigtrap(%d %d %x)\n",signal,code,context)); + sigsetmask(context->sc_mask); + SAVE_CONTEXT(); + /* this is just for info in case monitor wants to print an approx */ + current_control_stack_pointer = (unsigned long*)context->sc_sp; + /* On entry %eip points just after the INT3 byte and aims at the + * 'kind' value (eg trap_Cerror). For error-trap and Cerror-trap a + * number of bytes will follow, the first is the length of the byte + * arguments to follow. */ + if( *(unsigned char*)(context->sc_pc-1) == BREAKPOINT_INST) + { + if(after_breakpoint) code = AfterBreakpoint; /* ?? */ + else code = (int)*(char*)context->sc_pc; + } + switch (code) + { + case trap_PendingInterrupt: + DPRINTF(0,(stderr,"<trap Pending Interrupt.>\n")); + arch_skip_instruction(context); + interrupt_handle_pending(context); + break; + + case trap_Halt: + fake_foreign_function_call(context); + lose("%%primitive halt called; the party is over.\n"); + undo_fake_foreign_function_call(context); + arch_skip_instruction(context); + break; + + case trap_Error: + case trap_Cerror: + DPRINTF(0,(stderr,"<trap Error %d>\n",code)); +#ifdef __linux__ + interrupt_internal_error(signal,contextstruct, code==trap_Cerror); +#else + interrupt_internal_error(signal, code, context, code==trap_Cerror); +#endif + break; + + case trap_Breakpoint: /* Not tested */ + (char*)context->sc_pc -= 1; + handle_breakpoint(signal, code, context); + break; + + case trap_FunctionEndBreakpoint: /* not tested */ + (char*)context->sc_pc -= 1; + context->sc_pc = (int)handle_function_end_breakpoint(signal, code, context); + break; + + case AfterBreakpoint: /* not tested */ + DPRINTF(1,(stderr,"[C--AfterBreakpoint NOT TESTED]\n")); + (char*)context->sc_pc -= 1; + *skipped_break_addr = BREAKPOINT_INST; + os_flush_icache((os_vm_address_t)skipped_break_addr, + sizeof(unsigned long)); + skipped_break_addr = NULL; + *(unsigned int *)context->sc_pc = displaced_after_inst; + os_flush_icache((os_vm_address_t)context->sc_pc, sizeof(unsigned long)); + context->sc_mask = orig_sigmask; + after_breakpoint=NULL; + break; + + default: + DPRINTF(0,(stderr,"[C--trap default %d %d %x]\n",signal,code,context)); +#ifdef __linux__ + interrupt_handle_now(signal,contextstruct); +#else + interrupt_handle_now(signal, code, context); +#endif + break; + } +} + +#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2) + +extern void first_handler(); +void +arch_install_interrupt_handlers() +{ + interrupt_install_low_level_handler(SIGILL ,sigtrap_handler); + interrupt_install_low_level_handler(SIGTRAP,sigtrap_handler); +} + + +extern lispobj +call_into_lisp(lispobj fun, lispobj *args, int nargs); + +/* These next four functions are an interface to the + * Lisp call-in facility. Since this is C we can know + * nothing about the calling environment. The control + * stack might be the C stack if called from the monitor + * or the Lisp stack if called as a result of an interrupt + * or maybe even a separate stack. The args are most likely + * on that stack but could be in registers depending on + * what the compiler likes. So I try to package up the + * args into a portable vector and let the assembly language + * call-in function figure it out. + */ +lispobj +funcall0(lispobj function) +{ + lispobj *args = NULL; + + return call_into_lisp(function, args, 0); +} + +lispobj +funcall1(lispobj function, lispobj arg0) +{ + lispobj args[1]; + args[0] = arg0; + return call_into_lisp(function, args, 1); +} + +lispobj +funcall2(lispobj function, lispobj arg0, lispobj arg1) +{ + lispobj args[2]; + args[0] = arg0; + args[1] = arg1; + return call_into_lisp(function, args, 2); +} + +lispobj +funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2) +{ + lispobj args[3]; + args[0] = arg0; + args[1] = arg1; + args[2] = arg2; + return call_into_lisp(function, args, 3); +} diff --git a/lisp/x86-assem.S b/lisp/x86-assem.S new file mode 100644 index 000000000..8ebad823f --- /dev/null +++ b/lisp/x86-assem.S @@ -0,0 +1,438 @@ +### x86-assem.S -*- Mode: Asm; -*- +/** + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-assem.S,v 1.1 1997/01/21 00:28:13 ram Exp $ + * + * Author: Paul F. Werkowski <pw@snoopy.mv.com> + * + * This code was written to support the port of CMU Common Lisp + * to the Intel X86 ISA and the FreeBSD operating system. The + * author has placed this code in the public domain September 1996. + * + */ + + +#include "x86-validate.h" + +#define LANGUAGE_ASSEMBLY +#include "internals.h" + +/* Minimize conditionalization for different OS naming schemes */ +#if defined __linux__ +#define GNAME(var) var +#else +#define GNAME(var) _##var +#endif + +/* Get the right type of alignment. Linux as wants alignment in bytes? */ +/* not but .align 3 doesn't work ! in kernel it says: align 4 =16 bytes*/ +/* error is: +tmp/cca01184.s: Assembler messages: +/tmp/cca01184.s:553: Error: Alignment not a power of 2 +/tmp/cca01184.s:616: Error: Rest of line ignored. First ignored character is `,'. +*/ + +#ifdef __linux__ +#define align_4byte 2 +#define align_8byte 4 +#define align_16byte 4 +#else +#define align_4byte 2 +#define align_8byte 3 +#define align_16byte 4 +#endif + .text + .global GNAME(sigtrap_handler) + .global GNAME(foreign_function_call_active) + .global GNAME(purify) + .global GNAME(collect_garbage) + .global GNAME(current_control_stack_pointer) + .global GNAME(call_into_c) + .type GNAME(call_into_c),@function + .data + +Cstack: .long 0 +Purify: .long GNAME(purify) + + .text + + +/* + * The C function will preserve ebx, esi, edi, and ebp across its + * function call - ebx is used to save the return lisp address. + * + * Return values are in eax and maybe edx for quads, or st(0) for + * floats. + * + * It should work for lisp calls c calls lisp calls c .. + */ + .text + .align align_16byte,0x90 + .global GNAME(call_into_c) + .type GNAME(call_into_c),@function +GNAME(call_into_c): + movl $1,GNAME(foreign_function_call_active) + +/* Save the return lisp address in ebx */ + popl %ebx + +/* Setup the NPX for C */ + pushl %ecx # Make a little temp room. + fnstcw (%esp) # save exception masks + fninit + fldcw (%esp) # restore exception masks + popl %ecx # Restore the stack. + + call *%eax # normal callout using Lisp stack + + movl %eax,%ecx # remember integer return value + +/* Check for a return FP value */ + fxam + fnstsw %eax + andl $0x4500,%eax + cmpl $0x4100,%eax + jne Lfp_rtn_value + +/* The return value is in eax, or eax,edx? */ +/* Setup the NPX stack for lisp */ + fldz # insure no regs are empty + fldz + fldz + fldz + fldz + fldz + fldz + fldz + +/* Restore the return value */ + movl %ecx,%eax # maybe return value + + movl $0,GNAME(foreign_function_call_active) +/* Return */ + jmp *%ebx + +Lfp_rtn_value: +/* The return result is in st(0) */ +/* Setup the NPX stack for lisp, placing the result in st(0) */ + fldz # insure no regs are empty + fldz + fldz + fldz + fldz + fldz + fldz + fxch %st(7) # move the result back to st(0) + +/* Don't need to restore eax as the result is in st(0) */ + + movl $0,GNAME(foreign_function_call_active) +/* Return */ + jmp *%ebx + + .size GNAME(call_into_c), . - GNAME(call_into_c) + + .align align_16byte,0x90 + .type prep_mind_warp,@function +/* Purify wants to mess with the control stack and I can't really + * do that if I am also running on that stack. So I will transfer + * to the stack that was left at initial call_into_lisp time. + */ +prep_mind_warp: + movl %esp,GNAME(current_control_stack_pointer) + movl %esp,%ecx # temp + xchgl %esp,Cstack # now on C stack + pushl 8(%ecx) # arg 2 + pushl 4(%ecx) # arg 1 + call *%eax # purify + addl $8,%esp # pop 2 args + xchgl %esp,Cstack # back to lisp stack + +/* Purify does not return a fp value, so don't need to check, + * just setup the lisp stack for Lisp */ + fldz # insure no regs are not empty + fldz + fldz + fldz + fldz + fldz + fldz + fldz + + movl $0,GNAME(foreign_function_call_active) +/* Return */ + jmp %ebx + .size prep_mind_warp, . - prep_mind_warp + + + + .type GNAME(do_purify),@function + .global GNAME(do_purify) +/* This is called from save to purge dynamic memory. + * + * dtc: We are now on the lisp stack, but got here via a call_into_c so we + * are in foreign_function land. Since a lisp image is being saved and + * lisp will not be returned to it's not important to preserve + * state which is not significant to saving an image. + * + * Need to see where any dynamic objects end up. + * This seems like an incredible hack. Maybe I can fix purify. + */ +GNAME(do_purify): + movl %esp,GNAME(current_control_stack_pointer) + + movl %esp,%ecx # temp + xchgl %esp,Cstack # now on C stack + + pushl %ebp # save old frame pointer + movl %esp,%ebp # establish new frame + + pushl 8(%ecx) # arg 2 + pushl 4(%ecx) # arg 1 + call GNAME(purify) # purify + addl $8,%esp # pop 2 args + + popl %ebp + + xchgl %esp,Cstack # back to lisp stack + + ret + .size GNAME(do_purify), . - GNAME(do_purify) + + + .global GNAME(call_into_lisp) + .type GNAME(call_into_lisp),@function +fpmask: .word 0x33f # 64-bit precision | all execptions masked + +/* The C conventions require that ebx, esi, edi, and ebp be preserved + across function calls. */ + + .align align_16byte,0x90 +GNAME(call_into_lisp): + pushl %ebp # save old frame pointer + movl %esp,%ebp # establish new frame + +/* Save the NPX state */ + subl $108,%esp # Make room for the NPX state. + fnsave (%esp) # Resets NPX + fldcw (%esp) # Recover modes + fldz # insure no regs are not empty + fldz + fldz + fldz + fldz + fldz + fldz + fldz + +/* Save C regs: ebx esi edi */ + pushl %ebx + pushl %esi + pushl %edi + +/* clear descriptor regs */ + xorl %eax,%eax # lexenv + movl %eax,%ebx # available + movl %eax,%ecx # arg count + movl %eax,%edx # first arg + movl %eax,%edi # second arg + movl %eax,%esi # third arg + +/* establish nil (?) */ + +/* start pseudo-atomic (?) */ + +/* no longer in function call */ + movl %eax, GNAME(foreign_function_call_active) + + movl %esp,%ebx # remember current stack +/* load lisp state */ + /* dyn space free */ + /* binding stack */ + /* control stack (esp) */ + movl $CONTROL_STACK_START,%ecx + movl %ecx,%edx + addl $CONTROL_STACK_SIZE,%edx + cmpl %ecx,%esp # low - sp + jbe LispStackSet # jump when sp "below or equal" low + cmpl %edx,%esp # hgh - sp + jbe LispStackOk +LispStackSet: # probably called from Monitor + movl %esp,Cstack # save C stack for use by GC/Purify + movl %edx,%esp # now at bottom of Lisp stack +LispStackOk: + pushl %ebx # save entry stack on (maybe) new stack + /* control frame (ebp) */ + /* end pseudo-atomic */ + + /* establish lisp args */ + movl 8(%ebp),%eax # lexenv? + movl 12(%ebp),%ebx # address of arg vec + movl 16(%ebp),%ecx # num args + shll $2,%ecx # make into fixnum + cmpl $0,%ecx + je Ldone + movl (%ebx),%edx # arg0 + cmpl $4,%ecx + je Ldone + movl 4(%ebx),%edi # arg1 + cmpl $8,%ecx + je Ldone + movl 8(%ebx),%esi # arg2 +Ldone: + /* registers eax, ecx, edx,edi,esi now live */ + + + /* alloc new frame */ + mov %esp,%ebx # current sp marks start of new frame + push %ebp # fp in save location S0 + mov %ebx,%ebp # switch to new frame + + /* lra in the save location */ + pushl $Llra + + /* push the lra for backward compatibility */ + pushl $Llra + + /* indirect the closure */ + jmp *CLOSURE_FUNCTION_OFFSET(%eax) + + .align align_8byte + .long type_ReturnPcHeader + nop + nop + nop +Llra: + /* Multi-value return - blow off any extra values */ + mov %ebx, %esp + + /* Single value return */ + popl %esp # c-sp + +/* restore C regs: ebx esi edi */ + popl %edi + popl %esi + popl %ebx + +/* Restore the NPX state */ + frstor (%esp) + addl $108, %esp + + popl %ebp # c-sp + movl %edx,%eax # c-val + ret + .size GNAME(call_into_lisp), . - GNAME(call_into_lisp) + + +/* Fdefn objects for undefined functions have a 'raw' slot + pointing here. The RISC systems seem to have this set up + as an actual function object instead. + */ + .text + .align align_4byte,0x90 + .global GNAME(undefined_tramp) + .type GNAME(undefined_tramp),@function +GNAME(undefined_tramp): + int3 + .byte trap_Cerror + .byte 2 + .byte 23 + .byte 14 + ret + .size GNAME(undefined_tramp), .-GNAME(undefined_tramp) + +/* This apparently gets called to hack on something in closures + that can't get done by the compiler. +*/ + .align align_4byte,0x90 + .global GNAME(closure_tramp) + .type GNAME(closure_tramp),@function +GNAME(closure_tramp): + movl FDEFN_FUNCTION_OFFSET(%eax),%eax + jmp CLOSURE_FUNCTION_OFFSET(%eax) + + .size GNAME(closure_tramp), .-GNAME(closure_tramp) + + .align align_4byte + .global GNAME(function_end_breakpoint_trap) + .global GNAME(function_end_breakpoint_end) + .global GNAME(function_end_breakpoint_guts) + +GNAME(function_end_breakpoint_trap): + ret + .align align_4byte +GNAME(function_end_breakpoint_guts): + ret + .align align_4byte +GNAME(function_end_breakpoint_end): + ret + + .global GNAME(test_point) + .align align_4byte +GNAME(test_point): + ret + + + .global GNAME(do_pending_interrupt) + .type GNAME(do_pending_interrupt),@function + .align align_4byte,0x90 +GNAME(do_pending_interrupt): + int3 + .byte trap_PendingInterrupt + ret + .size GNAME(do_pending_interrupt),.-GNAME(do_pending_interrupt) + +/* A copy function optimized for the Pentium and works ok on + * 486 as well. This assumes (does not check) that the input + * byte count is a multiple of 8-bytes (one lisp object). + * This code takes advantage of pairing in the Pentium as well + * as the 128-bit cache line. + */ + .global GNAME(fastcopy16) + .type GNAME(fastcopy16),@function + .align align_4byte,0x90 +GNAME(fastcopy16): + pushl %ebp + movl %esp,%ebp + movl 8(%ebp), %edx # dst + movl 12(%ebp),%eax # src + movl 16(%ebp),%ecx # bytes + pushl %ebx + pushl %esi + pushl %edi + movl %edx,%edi + movl %eax,%esi + sarl $3,%ecx # number 8-byte units + testl $1,%ecx # odd? + jz Lquad + movl (%esi),%eax + movl 4(%esi),%ebx + movl %eax,(%edi) + movl %ebx,4(%edi) + leal 8(%esi),%esi + leal 8(%edi),%edi +Lquad: sarl $1,%ecx # count 16-byte units + jz Lend + movl %ecx,%ebp # use ebp for loop counter + .align align_16byte,0x90 +Ltop: + movl (%edi),%eax #prefetch! MAJOR Pentium win. + movl (%esi),%eax + movl 4(%esi),%ebx + movl 8(%esi),%ecx + movl 12(%esi),%edx + movl %eax, (%edi) + movl %ebx, 4(%edi) + movl %ecx, 8(%edi) + movl %edx,12(%edi) + leal 16(%esi),%esi + leal 16(%edi),%edi + decl %ebp + jnz Ltop # non-prefixed jump saves cycles +Lend: + popl %edi + popl %esi + popl %ebx + popl %ebp + ret + .size GNAME(fastcopy16),.-GNAME(fastcopy16) + .end diff --git a/lisp/x86-lispregs.h b/lisp/x86-lispregs.h new file mode 100644 index 000000000..e81b38520 --- /dev/null +++ b/lisp/x86-lispregs.h @@ -0,0 +1,45 @@ +/* 86-lispregs.h -*- Mode: C; -*- + * + */ + +/* These register names and offsets correspond to definitions + * in compiler/x86/vm.lisp. They map into accessors in the + * os dependent <machine/signal.h> structure via the sc_reg + * os dependent function. + */ + +#define NREGS (8) + +#ifdef LANGUAGE_ASSEMBLY +#define REG(num) $ ## num +#else +#define REG(num) num +#endif + +#define reg_EAX REG( 0) +#define reg_ECX REG( 2) +#define reg_EDX REG( 4) +#define reg_EBX REG( 6) +#define reg_ESP REG( 8) +#define reg_EBP REG(10) +#define reg_ESI REG(12) +#define reg_EDI REG(14) + +#define reg_SP reg_ESP +#define reg_FP reg_EBP + +#define REGNAMES "EAX", "ECX", "EDX", "EBX", "ESP", "EBP", "ESI", "EDI" + +/* These registers can contain lisp object pointers */ +#define BOXED_REGISTERS {\ + reg_EAX, reg_ECX, reg_EDX, reg_EBX, reg_ESI, reg_EDI \ + } + +/* N is offset in storage class (SC) as defined in vm.lisp. + * Ordering in sigcontext is probably os dependent so let + * xxx-os.c handle it. + */ + +#define SC_REG(sc, n) sc_reg(sc,n) +#define SC_PC(sc) ((sc)->sc_pc) + diff --git a/lisp/x86-validate.h b/lisp/x86-validate.h new file mode 100644 index 000000000..e71dea8de --- /dev/null +++ b/lisp/x86-validate.h @@ -0,0 +1,29 @@ +/* + + This code was written as part of the CMU Common Lisp project at + Carnegie Mellon University, and has been placed in the public domain. + +*/ + + +#define READ_ONLY_SPACE_START (0x01000000) +#define READ_ONLY_SPACE_SIZE (0x04000000) /* 64MB!! */ + +#define STATIC_SPACE_START (0x05000000) +#define STATIC_SPACE_SIZE (0x02fff000) /* 64MB - 1 page */ + +#define DYNAMIC_0_SPACE_START (0x09000000) +#define DYNAMIC_1_SPACE_START (0x0d000000) +#define DYNAMIC_SPACE_SIZE (0x04000000) + +/* Note that i386 has the stack growing from high + * to low addresses. The code for the RISC systems + * seem to go the other way. May have to make + * a lot of changes in the GC and supporting code + * to account for stack direction. + */ +#define CONTROL_STACK_START (0x50000000) +#define CONTROL_STACK_SIZE (0x00100000) + +#define BINDING_STACK_START (0x60000000) +#define BINDING_STACK_SIZE (0x00100000) -- GitLab