Skip to content
Snippets Groups Projects
Commit 5ced0fdf authored by ram's avatar ram
Browse files

source kit 1.03.7

parent c0c98ded
No related branches found
No related tags found
No related merge requests found
Showing with 3588 additions and 20 deletions
;;; -*- 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))
;;; -*- 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))
;;; -*- 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))
;;; -*- 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))))
;; Just a dummy file to keep loadbackend happy.
;;; -*- 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))
;;; -*- 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)))
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
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
/*
* 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
/*
$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
# $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 all: lisp.nm
CC = gcc CC = gcc
DEPEND_FLAGS = DEPEND_FLAGS =
include Config include Config
ifndef GC_SRC
GC_SRC = gc.c
endif
SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c \ 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 \ dynbind.c breakpoint.c regnames.c backtrace.c save.c purify.c \
socket.c runprog.c time.c undefineds.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)))) 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)))) ...@@ -21,7 +25,7 @@ OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(patsubst %.s,%.o,$(SRCS))))
lisp.nm: lisp lisp.nm: lisp
echo 'Map file for lisp version ' `cat version` > ,lisp.nm 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 mv ,lisp.nm lisp.nm
lisp: version.c ${OBJS} version lisp: version.c ${OBJS} version
......
/*
* 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
/*
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
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.
/* $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 "lisp.h"
#include "internals.h" #include "internals.h"
...@@ -22,12 +22,14 @@ ...@@ -22,12 +22,14 @@
clear_auto_gc_trigger(); set_auto_gc_trigger(new_value); clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
#endif #endif
#define ALIGNED_SIZE(n) (n+lowtag_Mask) & ~lowtag_Mask
/**************************************************************** /****************************************************************
Allocation Routines. Allocation Routines.
****************************************************************/ ****************************************************************/
#if defined WANT_CGC
extern lispobj *alloc(int bytes);
#else
static lispobj *alloc(int bytes) static lispobj *alloc(int bytes)
{ {
lispobj *result; lispobj *result;
...@@ -45,12 +47,13 @@ static lispobj *alloc(int bytes) ...@@ -45,12 +47,13 @@ static lispobj *alloc(int bytes)
return result; return result;
} }
#endif
static lispobj *alloc_unboxed(int type, int words) static lispobj *alloc_unboxed(int type, int words)
{ {
lispobj *result; lispobj *result;
result = alloc((1 + words) * sizeof(lispobj)); result = alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)));
*result = (lispobj) (words << type_Bits) | type; *result = (lispobj) (words << type_Bits) | type;
...@@ -61,7 +64,8 @@ static lispobj alloc_vector(int type, int length, int size) ...@@ -61,7 +64,8 @@ static lispobj alloc_vector(int type, int length, int size)
{ {
struct vector *result; 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->header = type;
result->length = make_fixnum(length); result->length = make_fixnum(length);
...@@ -71,7 +75,7 @@ static lispobj alloc_vector(int type, int length, int size) ...@@ -71,7 +75,7 @@ static lispobj alloc_vector(int type, int length, int size)
lispobj alloc_cons(lispobj car, lispobj cdr) 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->car = car;
ptr->cdr = cdr; ptr->cdr = cdr;
......
lisp/cgc.c 0 → 100644
This diff is collapsed.
/* cgc.h -*- Mode: C; comment-column: 40; -*-
*
* Conservative GC for CMUCL X86
*
*/
void*cgc_alloc(int);
void cgc_free_heap(void);
/* $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 <stdio.h>
#include <sys/types.h> #include <sys/types.h>
#include <sys/file.h> #include <sys/file.h>
...@@ -35,12 +35,12 @@ static void process_directory(int fd, long *ptr, int count) ...@@ -35,12 +35,12 @@ static void process_directory(int fd, long *ptr, int count)
if (len != 0) { if (len != 0) {
os_vm_address_t real_addr; os_vm_address_t real_addr;
#ifdef PRINTNOISE #ifdef PRINTNOISE
printf("Mapping %d bytes at 0x%x.\n", len, addr); printf("Mapping %ld bytes at 0x%lx.\n", len, addr);
#endif #endif
real_addr=os_map(fd, offset, addr, len); real_addr=os_map(fd, offset, addr, len);
if(real_addr!=addr) if(real_addr!=addr)
fprintf(stderr, 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, real_addr,
addr); addr);
} }
...@@ -55,7 +55,7 @@ static void process_directory(int fd, long *ptr, int count) ...@@ -55,7 +55,7 @@ static void process_directory(int fd, long *ptr, int count)
&& addr != (os_vm_address_t)dynamic_1_space) && addr != (os_vm_address_t)dynamic_1_space)
printf("Strange ... dynamic space lossage.\n"); printf("Strange ... dynamic space lossage.\n");
current_dynamic_space = (lispobj *)addr; current_dynamic_space = (lispobj *)addr;
#ifdef ibmrt #if defined(ibmrt) || defined(i386)
SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer); SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
#else #else
current_dynamic_space_free_pointer = free_pointer; current_dynamic_space_free_pointer = free_pointer;
...@@ -68,7 +68,7 @@ static void process_directory(int fd, long *ptr, int count) ...@@ -68,7 +68,7 @@ static void process_directory(int fd, long *ptr, int count)
/* Don't care about read only space */ /* Don't care about read only space */
break; break;
default: default:
printf("Strange space ID: %d; ignored.\n", id); printf("Strange space ID: %ld; ignored.\n", id);
break; break;
} }
entry++; entry++;
...@@ -105,7 +105,7 @@ lispobj load_core_file(char *file) ...@@ -105,7 +105,7 @@ lispobj load_core_file(char *file)
val = *ptr++; val = *ptr++;
if (val != CORE_MAGIC) { 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); val, CORE_MAGIC);
exit(1); exit(1);
} }
...@@ -147,7 +147,7 @@ lispobj load_core_file(char *file) ...@@ -147,7 +147,7 @@ lispobj load_core_file(char *file)
break; break;
default: default:
printf("Unknown core file entry: %d; skipping.\n", val); printf("Unknown core file entry: %ld; skipping.\n", val);
break; break;
} }
......
/* /*
* $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. * Support for dynamic binding from C.
*/ */
...@@ -9,7 +9,7 @@ ...@@ -9,7 +9,7 @@
#include "globals.h" #include "globals.h"
#include "dynbind.h" #include "dynbind.h"
#ifdef ibmrt #if defined(ibmrt) || defined(i386)
#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER)) #define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value)) #define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value))
#else #else
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment