imported compiler1
This commit is contained in:
parent
d3313cd737
commit
3e7726203a
|
@ -1 +1,3 @@
|
|||
*.s
|
||||
*.tmp
|
||||
*.out
|
||||
|
|
|
@ -1,67 +0,0 @@
|
|||
#if 0
|
||||
Taken from
|
||||
http://www.azillionmonkeys.com/qed/hash.html
|
||||
|
||||
#endif
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#undef get16bits
|
||||
#if (defined(__GNUC__) && defined(__i386__)) || defined(__WATCOMC__) \
|
||||
|| defined(_MSC_VER) || defined (__BORLANDC__) || defined (__TURBOC__)
|
||||
#define get16bits(d) (*((const uint16_t *) (d)))
|
||||
#endif
|
||||
|
||||
#if !defined (get16bits)
|
||||
#define get16bits(d) ((((const uint8_t *)(d))[1] << UINT32_C(8))\
|
||||
+((const uint8_t *)(d))[0])
|
||||
#endif
|
||||
|
||||
|
||||
char* SuperFastHash (char* str) {
|
||||
char* data = str + disp_string_data - string_tag;
|
||||
int len = (int) ref(str, disp_string_length - string_tag);
|
||||
len = len >> fx_shift;
|
||||
|
||||
uint32_t hash = len, tmp;
|
||||
int rem;
|
||||
|
||||
if (len <= 0 || data == NULL) return 0;
|
||||
|
||||
rem = len & 3;
|
||||
len >>= 2;
|
||||
|
||||
/* Main loop */
|
||||
for (;len > 0; len--) {
|
||||
hash += get16bits (data);
|
||||
tmp = (get16bits (data+2) << 11) ^ hash;
|
||||
hash = (hash << 16) ^ tmp;
|
||||
data += 2*sizeof (uint16_t);
|
||||
hash += hash >> 11;
|
||||
}
|
||||
|
||||
/* Handle end cases */
|
||||
switch (rem) {
|
||||
case 3: hash += get16bits (data);
|
||||
hash ^= hash << 16;
|
||||
hash ^= data[sizeof (uint16_t)] << 18;
|
||||
hash += hash >> 11;
|
||||
break;
|
||||
case 2: hash += get16bits (data);
|
||||
hash ^= hash << 11;
|
||||
hash += hash >> 17;
|
||||
break;
|
||||
case 1: hash += *data;
|
||||
hash ^= hash << 10;
|
||||
hash += hash >> 1;
|
||||
}
|
||||
|
||||
/* Force "avalanching" of final 127 bits */
|
||||
hash ^= hash << 3;
|
||||
hash += hash >> 5;
|
||||
hash ^= hash << 4;
|
||||
hash += hash >> 17;
|
||||
hash ^= hash << 25;
|
||||
hash += hash >> 6;
|
||||
|
||||
return (char*)(hash<<fx_shift);
|
||||
}
|
|
@ -1,6 +1,77 @@
|
|||
|
||||
(load "chez-compat.ss")
|
||||
|
||||
(load "libintelasm-5.8.ss")
|
||||
(load "libfasl-6.0.ss")
|
||||
|
||||
(define-record code (code-size reloc-size closure-size code-vec reloc-vec))
|
||||
(define make-code
|
||||
(let ([make-code make-code])
|
||||
(lambda (code-size reloc-size closure-size)
|
||||
(printf "reloc=~s\n" reloc-size)
|
||||
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
|
||||
(make-code
|
||||
(fxsra code-size 2)
|
||||
(fxsra reloc-size 2)
|
||||
closure-size
|
||||
(make-vector code-size (cons 'byte 0))
|
||||
(make-vector (fxsra reloc-size 2)))))))
|
||||
|
||||
(define set-code-byte!
|
||||
(lambda (code idx byte)
|
||||
(vector-set! (code-code-vec code) idx (cons 'byte byte))))
|
||||
|
||||
|
||||
(define set-code-word!
|
||||
(lambda (code idx x)
|
||||
(cond
|
||||
[(fixnum? x)
|
||||
(set-code-byte! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2))
|
||||
(set-code-byte! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF))
|
||||
(set-code-byte! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF))
|
||||
(set-code-byte! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))]
|
||||
[else (error 'set-code-word! "unhandled ~s" x)])))
|
||||
|
||||
(define set-code-object!
|
||||
(lambda (code obj code-idx reloc-idx)
|
||||
(let ([v (code-reloc-vec code)])
|
||||
(vector-set! v reloc-idx (list 'object code-idx obj)))))
|
||||
|
||||
(define set-code-object+offset/rel!
|
||||
(lambda (code obj code-idx obj-idx reloc-idx)
|
||||
(let ([v (code-reloc-vec code)])
|
||||
(vector-set! v reloc-idx
|
||||
(list 'object+off/rel code-idx obj obj-idx))
|
||||
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
|
||||
|
||||
(define set-code-object+offset!
|
||||
(lambda (code obj code-idx obj-idx reloc-idx)
|
||||
(let ([v (code-reloc-vec code)])
|
||||
(vector-set! v reloc-idx
|
||||
(list 'object+off code-idx obj obj-idx))
|
||||
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
|
||||
|
||||
(define make-code-executable!
|
||||
(lambda (x) (void)))
|
||||
|
||||
|
||||
|
||||
(define eval-code
|
||||
(lambda (code)
|
||||
(with-output-to-file "stst.fasl"
|
||||
(lambda ()
|
||||
(fasl-write code))
|
||||
'replace)
|
||||
(let ([rv (system "runtime/ikarus stst.fasl > stst.tmp")])
|
||||
(unless (zero? rv)
|
||||
(error 'eval-code "Failed to run: ~s" rv)))
|
||||
(with-input-from-file "stst.tmp" read)))
|
||||
|
||||
|
||||
|
||||
|
||||
(let ()
|
||||
(define verbose #f)
|
||||
(define verbose #t)
|
||||
(define passed-tests 0)
|
||||
|
||||
(define all-tests 0)
|
||||
|
@ -9,9 +80,8 @@
|
|||
(lambda (code-ls val)
|
||||
(set! all-tests (fxadd1 all-tests))
|
||||
(when verbose (printf "Evaluating\n~s\n" code-ls))
|
||||
(let* ([code (car (#%list*->code* (list code-ls)))]
|
||||
[proc (code->closure code)]
|
||||
[v (proc)])
|
||||
(let* ([code (car (list*->code* (list code-ls)))]
|
||||
[v (eval-code code)])
|
||||
(when verbose (printf "evaluated\n"))
|
||||
(cond
|
||||
[(equal? v val)
|
||||
|
@ -21,10 +91,41 @@
|
|||
(error 'test-code
|
||||
"expected ~s, got ~s" val v)]))))
|
||||
|
||||
(printf "testing ... \n")
|
||||
|
||||
(test-code
|
||||
'([ret])
|
||||
'([movl (int 0) %eax]
|
||||
[ret])
|
||||
0)
|
||||
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (obj 10) %eax]
|
||||
[jmp (label ,L1)]
|
||||
[byte 0]
|
||||
[byte 1]
|
||||
[byte 2]
|
||||
[byte 3]
|
||||
[byte 4]
|
||||
[byte 5]
|
||||
[byte 6]
|
||||
[byte 7]
|
||||
[byte 8]
|
||||
[byte 9]
|
||||
[label ,L1]
|
||||
[ret])
|
||||
10))
|
||||
|
||||
(test-code
|
||||
'([movl (obj+ (1 2 3) 3) %eax]
|
||||
[movl (disp (int 0) %eax) %eax]
|
||||
[ret])
|
||||
'(2 3))
|
||||
|
||||
|
||||
|
||||
|
||||
(test-code
|
||||
'([movl (int 40) %eax]
|
||||
[ret])
|
||||
|
@ -282,31 +383,31 @@
|
|||
[ret])
|
||||
'list)
|
||||
|
||||
(test-code
|
||||
'([movl (obj list) %eax]
|
||||
[movl (disp (int 6) %eax) %eax] ; symbol value
|
||||
[ret])
|
||||
list)
|
||||
;; (test-code
|
||||
;; '([movl (obj list) %eax]
|
||||
;; [movl (disp (int 6) %eax) %eax] ; symbol value
|
||||
;; [ret])
|
||||
;; list)
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) (disp (int -4) %esp)]
|
||||
[movl (obj list) %eax]
|
||||
[movl (disp (int 6) %eax) %edi] ; symbol value
|
||||
[movl (obj -1) %eax] ; argc
|
||||
[jmp (disp (int -3) %edi)])
|
||||
'(10))
|
||||
;; (test-code
|
||||
;; '([movl (obj 10) (disp (int -4) %esp)]
|
||||
;; [movl (obj list) %eax]
|
||||
;; [movl (disp (int 6) %eax) %edi] ; symbol value
|
||||
;; [movl (obj -1) %eax] ; argc
|
||||
;; [jmp (disp (int -3) %edi)])
|
||||
;; '(10))
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) (disp (int -4) %esp)]
|
||||
[movl (obj 20) %eax]
|
||||
[movl %eax (disp (int -8) %esp)]
|
||||
[movl (disp (int -8) %esp) %ebx]
|
||||
[movl %ebx (disp (int -12) %esp)]
|
||||
[movl (obj list) %eax]
|
||||
[movl (disp (int 6) %eax) %edi] ; symbol value
|
||||
[movl (obj -3) %eax] ; argc
|
||||
[jmp (disp (int -3) %edi)])
|
||||
'(10 20 20))
|
||||
;; (test-code
|
||||
;; '([movl (obj 10) (disp (int -4) %esp)]
|
||||
;; [movl (obj 20) %eax]
|
||||
;; [movl %eax (disp (int -8) %esp)]
|
||||
;; [movl (disp (int -8) %esp) %ebx]
|
||||
;; [movl %ebx (disp (int -12) %esp)]
|
||||
;; [movl (obj list) %eax]
|
||||
;; [movl (disp (int 6) %eax) %edi] ; symbol value
|
||||
;; [movl (obj -3) %eax] ; argc
|
||||
;; [jmp (disp (int -3) %edi)])
|
||||
;; '(10 20 20))
|
||||
|
||||
(test-code
|
||||
'([movl (obj 10) %eax]
|
||||
|
@ -362,24 +463,24 @@
|
|||
`([movl (int 10) %eax]
|
||||
[cmpl (int 8) %eax]
|
||||
[jne (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[movl (obj 0) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[movl (obj 1) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
1))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 40) %eax]
|
||||
[cmpl (obj 10) %eax]
|
||||
[je (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[movl (obj 0) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[movl (obj 1) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
1))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
|
@ -387,24 +488,24 @@
|
|||
[movl (int 30) %ebx]
|
||||
[cmpl %ebx %eax]
|
||||
[jge (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[movl (obj 0) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[movl (obj 1) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
1))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
`([movl (int 40) (disp (int -4) %esp)]
|
||||
[cmpl (int 70) (disp (int -4) %esp)]
|
||||
[jle (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[movl (obj 0) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[movl (obj 1) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
1))
|
||||
|
||||
(test-code
|
||||
'([movl (int 40) (disp (int -4) %esp)]
|
||||
|
@ -429,13 +530,13 @@
|
|||
[cmpl (int 70) (disp (int -1004) %esp)]
|
||||
[jle (label ,L1)]
|
||||
[addl (int -1000) %esp]
|
||||
[movl (obj #f) %eax]
|
||||
[movl (obj 0) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[addl (int -1000) %esp]
|
||||
[movl (obj #t) %eax]
|
||||
[movl (obj 1) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
1))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
|
@ -444,13 +545,13 @@
|
|||
[cmpl (int 7000) (disp (int -1004) %esp)]
|
||||
[jle (label ,L1)]
|
||||
[addl (int -1000) %esp]
|
||||
[movl (obj #f) %eax]
|
||||
[movl (obj 0) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[addl (int -1000) %esp]
|
||||
[movl (obj #t) %eax]
|
||||
[movl (obj 1) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
1))
|
||||
|
||||
(let ([L1 (gensym)])
|
||||
(test-code
|
||||
|
@ -458,12 +559,12 @@
|
|||
[movl (int 70) %ebx]
|
||||
[cmpl (disp (int -4) %esp) %ebx]
|
||||
[jge (label ,L1)]
|
||||
[movl (obj #f) %eax]
|
||||
[movl (obj 0) %eax]
|
||||
[ret]
|
||||
[label ,L1]
|
||||
[movl (obj #t) %eax]
|
||||
[movl (obj 1) %eax]
|
||||
[ret])
|
||||
#t))
|
||||
1))
|
||||
|
||||
|
||||
(let ([L_fact (gensym)] [L1 (gensym)])
|
||||
|
|
|
@ -1,171 +0,0 @@
|
|||
|
||||
;;; Instruction format:
|
||||
;;; 0,1,2,3,4 byte prefixes
|
||||
;;; 1,2,3 byte opcode
|
||||
;;; 0,1 byte ModR/M
|
||||
;;; 0,1 byte SIB
|
||||
;;; 0,1,2,4 bytes address displacement
|
||||
;;; 0,1,2,4 bytes immediate
|
||||
;;;
|
||||
;;; Prefixes:
|
||||
;;; 0 to 4 prefixes are permitted. Up to one prefix from each of the
|
||||
;;; following groups is permitted (in any order)
|
||||
;;; Group 1: Lock and Repeat
|
||||
;;; 0xF0 -- LOCK
|
||||
;;; 0xF2 -- REPNE/REPNZ (for string instructions)
|
||||
;;; 0xF3 -- REPE/REPX (for string instructions)
|
||||
;;; Group 2: Segment override and branch hints
|
||||
;;; 0x2E -- CS segment override
|
||||
;;; 0x36 -- SS
|
||||
;;; 0x3E -- DS
|
||||
;;; 0x26 -- ES
|
||||
;;; 0x64 -- FS
|
||||
;;; 0x65 -- GS
|
||||
;;; Group 3:
|
||||
;;; 0x66 -- Operand-size override
|
||||
;;; Group 4:
|
||||
;;; 0x67 -- Address-size override
|
||||
;;;
|
||||
;;; Opcodes:
|
||||
;;; * Either 1 byte opcode
|
||||
;;; * Or 2-bytes formed by 0x0F escape opcode followed by a second opcode
|
||||
;;; * Or 3-bytes formed by 0x66,0xF2,0xF3 prefix followed by escape opcode,
|
||||
;;; then a second opcode
|
||||
;;;
|
||||
;;; Mod/RM: 1 byte
|
||||
;;; ._________._____________.___________.
|
||||
;;; Bits: | 7 6 | 5 4 3 | 2 1 0 |
|
||||
;;; | mod | reg/opcode | R/M |
|
||||
;;; `~~~~~~~~~^~~~~~~~~~~~~~^~~~~~~~~~~~'
|
||||
;;; Refer to table 2-2 Page 39 from IA32 Vol2A instruction set reference
|
||||
;;;
|
||||
;;; Mod:
|
||||
;;; 0b00 -- direct dereference (i.e. [EAX], [ECX], ... , sib, disp32)
|
||||
;;; 0b01 -- deref + 8-bit disp (i.e. [EAX]+disp8, ...)
|
||||
;;; 0b10 -- deref + 32-bit disp
|
||||
;;; 0b11 -- register name (i.e. EAX, ECX, ...)
|
||||
;;;
|
||||
;;; R/M: In general, the register names are as follows:
|
||||
;;; 0b000 -- eax
|
||||
;;; 0b001 -- ecx
|
||||
;;; 0b010 -- edx
|
||||
;;; 0b011 -- ebx
|
||||
;;; 0b100 -- esp
|
||||
;;; 0b101 -- ebp
|
||||
;;; 0b110 -- esi
|
||||
;;; 0b111 -- edi
|
||||
;;; Exceptions:
|
||||
;;; If mod is 0b00, 0b01 or 0b10:
|
||||
;;; then esp is invalid and 0b100 is used to denote the presence
|
||||
;;; of an SIB field
|
||||
;;; If mod is 0b00:
|
||||
;;; then ebp is invalid and 0b101 is used to denote a disp32 field
|
||||
;;; that follows the Mod/RM byte and (or the SIB byte if present).
|
||||
;;;
|
||||
;;; /r: The /r denoted the register operand, the numbers are the same
|
||||
;;; as above.
|
||||
;;;
|
||||
;;;
|
||||
;;; SIB: 1 byte
|
||||
;;; ._________._____________.___________.
|
||||
;;; Bits: | 7 6 | 5 4 3 | 2 1 0 |
|
||||
;;; | scale | index | base |
|
||||
;;; `~~~~~~~~~^~~~~~~~~~~~~~^~~~~~~~~~~~'
|
||||
;;; Refer to table 2-3 Page 40 from IA32 Vol2A instruction set reference
|
||||
;;;
|
||||
;;; Scale:
|
||||
;;; 0b00: multiply index register by 1 (no scale)
|
||||
;;; 0b01: multiply index register by 2
|
||||
;;; 0b10: multiply index register by 4
|
||||
;;; 0b11: multiply index register by 8
|
||||
;;;
|
||||
;;; Index: a register number
|
||||
;;; (esp or 0b100 is invalid as an index)
|
||||
;;;
|
||||
;;; Base: a register number
|
||||
;;; ebp or 0b101 as a base is interpreted as follows:
|
||||
;;; If mod == 0b00, then EA = scaled index + disp32 (no base)
|
||||
;;; If mod == 0b01, then EA = scaled index + disp8 + ebp
|
||||
;;; If mod == 0b10, then EA = scaled index + disp32 + ebp
|
||||
;;; If mod == 0b11, then I DON'T KNOW
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
|
||||
|
||||
(define-instr (TMPL1 primary secondary d s)
|
||||
(cases (d s)
|
||||
[(AL imm8) => (logor primary #b00000100) s] ; 04 ib
|
||||
[(EAX imm32) => (logor primary #b00000101) s] ; 05 id
|
||||
[(reg/mem8 imm8) => #b10000000 secondary ib] ; 80 /0 ib
|
||||
[(reg/mem32 imm32) => #b10000001 secondary id] ; 81 /0 id
|
||||
[(reg/mem32 imm8) => #b10000011 secondary ib] ; 83 /0 ib (sign ext.)
|
||||
[(reg/mem8 reg8) => (logor primary #b00000000) /r ] ; 00 /r
|
||||
[(reg/mem32 reg32) => (logor primary #b00000001) /r ] ; 01 /r
|
||||
[(reg8 reg/mem8) => (logor primary #b00000010) /r ] ; 02 /r
|
||||
[(reg32 reg/mem32) => (logor primary #b00000011) /r ] ; 03 /r
|
||||
))
|
||||
|
||||
(define-insrt (ADD d s) (TMPL1 #b00000000 /0 d s))
|
||||
|
||||
(define-insrt (AND d s) (TMPL1 #b00100000 /4 d s))
|
||||
|
||||
(define-instr (CMP d s) (TMPL1 #b00111000 /7 d s))
|
||||
|
||||
(define-insrt (CALL d)
|
||||
(cases (d)
|
||||
[(rel32of) => #b11101000 id] ; E8 id
|
||||
[(reg/mem32) => #b11111111 /2] ; FF /2
|
||||
))
|
||||
|
||||
(define-instr (CLTD) ; convert long to double
|
||||
(cases ()
|
||||
[() => #b10011001] ; 99
|
||||
))
|
||||
|
||||
(define-insrt (IDIV s)
|
||||
(cases (s)
|
||||
[(reg/mem8) => #b11110110 /7] ; F6 /7
|
||||
[(reg/mem32) => #b11110111 /7] ; F7 /7
|
||||
))
|
||||
|
||||
imull
|
||||
ja
|
||||
jae
|
||||
jb
|
||||
jbe
|
||||
je
|
||||
jg
|
||||
jge
|
||||
jl
|
||||
jle
|
||||
jmp
|
||||
jne
|
||||
movb
|
||||
movl
|
||||
movswl
|
||||
movzbl
|
||||
negl
|
||||
notl
|
||||
orl
|
||||
pop
|
||||
popl
|
||||
push
|
||||
pushl
|
||||
ret
|
||||
sall
|
||||
sarl
|
||||
sete
|
||||
setg
|
||||
setge
|
||||
setl
|
||||
setle
|
||||
shll
|
||||
shrl
|
||||
subl
|
||||
xorl
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
|
@ -1 +1 @@
|
|||
2006-07-19
|
||||
2006-07-27
|
||||
|
|
|
@ -3,64 +3,32 @@
|
|||
[(_ name val)
|
||||
(set-top-level-value! 'name val)]))
|
||||
|
||||
(define primitive-set! set-top-level-value!)
|
||||
|
||||
(define (immediate? x)
|
||||
(or (fixnum? x)
|
||||
(null? x)
|
||||
(char? x)
|
||||
(boolean? x)
|
||||
(eof-object? x)
|
||||
(eq? x (void))))
|
||||
|
||||
(define-syntax add1 syntax-error)
|
||||
(define fxadd1
|
||||
(lambda (x)
|
||||
(import scheme)
|
||||
(unless (fixnum? x) (error 'fxadd1 "~s is not a fixnum" x))
|
||||
(let ([v (+ x 1)])
|
||||
(unless (fixnum? v) (error 'fxadd1 "overflow"))
|
||||
v)))
|
||||
|
||||
(define-syntax sub1 syntax-error)
|
||||
(define fxsub1
|
||||
(lambda (x)
|
||||
(import scheme)
|
||||
(unless (fixnum? x) (error 'fxsub1 "~s is not a fixnum" x))
|
||||
(let ([v (- x 1)])
|
||||
(unless (fixnum? v) (error 'fxsub1 "overflow"))
|
||||
v)))
|
||||
|
||||
|
||||
|
||||
|
||||
(define-syntax - syntax-error)
|
||||
(define-syntax fx-
|
||||
(let ()
|
||||
(import scheme)
|
||||
(syntax-rules ()
|
||||
[(_ x y) (#%fx- x y)])))
|
||||
|
||||
(define-syntax * syntax-error)
|
||||
(define-syntax fx*
|
||||
(let ()
|
||||
(import scheme)
|
||||
(syntax-rules ()
|
||||
[(_ x y) (#%fx* x y)])))
|
||||
|
||||
(define-syntax + syntax-error)
|
||||
(define-syntax fx+
|
||||
(let ()
|
||||
(import scheme)
|
||||
(syntax-rules ()
|
||||
[(_ x y) (#%fx+ x y)])))
|
||||
|
||||
(define-syntax = syntax-error)
|
||||
(define-syntax fx=
|
||||
(let ()
|
||||
(import scheme)
|
||||
(syntax-rules ()
|
||||
[(_ x y) (#%fx= x y)])))
|
||||
|
||||
|
||||
|
||||
|
||||
(define-syntax integer? syntax-error)
|
||||
(define char= char=?)
|
||||
|
||||
|
||||
|
|
|
@ -1,399 +0,0 @@
|
|||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <sys/mman.h>
|
||||
#include <assert.h>
|
||||
#include "scheme.h"
|
||||
|
||||
typedef struct root_t{
|
||||
int count;
|
||||
char** start;
|
||||
struct root_t* next;
|
||||
} root_t;
|
||||
|
||||
void S_add_roots(pcb_t* pcb, int* f){
|
||||
int n = *f;
|
||||
if(n == 0) return;
|
||||
root_t* t = malloc(sizeof(root_t));
|
||||
if(t == NULL){
|
||||
fprintf(stderr, "Error mallocing\n");
|
||||
exit(-1);
|
||||
}
|
||||
t->count = n;
|
||||
t->start = (char**)(f+1);
|
||||
t->next = (root_t*) pcb->roots;
|
||||
pcb->roots = (char*) t;
|
||||
int i;
|
||||
for(i=1; i<=n; i++){
|
||||
assert(f[i] == 0);
|
||||
}
|
||||
}
|
||||
|
||||
void S_check_roots(pcb_t* pcb, int* f){
|
||||
int n = *f;
|
||||
int i;
|
||||
for(i=1; i<=n; i++){
|
||||
assert(f[i] != 0);
|
||||
}
|
||||
}
|
||||
|
||||
/* S_collect is called from scheme under the following conditions:
|
||||
* 1. An attempt is made to allocate a small object and the ap is above
|
||||
* the red line.
|
||||
* 2. The current frame of the call is dead, so, upon return from S_collect,
|
||||
* the caller returns to its caller.
|
||||
* 3. The frame-pointer of the caller to S_collect is saved at
|
||||
* pcb->stack_extent. No variables are live at that frame except for
|
||||
* the return point (at *(pcb->stack_extent)).
|
||||
* 4. S_collect must return a new ap (in pcb->allocation_pointer) that has
|
||||
* at least 2 pages of memory free.
|
||||
* 5. S_collect must also update pcb->allocaton_red_line to be 2 pages below
|
||||
* the real end of heap.
|
||||
* 6. S_collect should not move the stack.
|
||||
*/
|
||||
|
||||
#define pagesize 4096
|
||||
#define minimum_heap_size (pagesize * 640)
|
||||
#define align_to_page(x) (((x)/pagesize)*pagesize)
|
||||
static char* allocate_unprotected_space(int size);
|
||||
static void deallocate_unprotected_space(char* p, int size);
|
||||
static void deallocate_string_pages(char*);
|
||||
static void copy_roots(pcb_t* pcb);
|
||||
static char* move_object(char* x, pcb_t* pcb);
|
||||
|
||||
pcb_t* S_collect(int req, pcb_t* pcb){
|
||||
#if 0
|
||||
fprintf(stderr, "S_collect entry %d (pcb=0x%08x)\n", req, (int)pcb);
|
||||
#endif
|
||||
char* heap_base = pcb->heap_base;
|
||||
#if 0
|
||||
int heap_size = (int)pcb->heap_size;
|
||||
fprintf(stderr, "heapsize=0x%08x (0x%08x .. 0x%08x)\n",
|
||||
heap_size,
|
||||
(int) heap_base,
|
||||
(int) (heap_base + heap_size - 1));
|
||||
#endif
|
||||
int used_space = (int)(pcb->allocation_pointer - heap_base);
|
||||
{
|
||||
int bytes = (int) pcb->allocated_bytes + (used_space & 0xFFFFF);
|
||||
pcb->allocated_megs += (bytes >> 20);
|
||||
pcb->allocated_bytes = (char*) (bytes & 0xFFFFF);
|
||||
#if 0
|
||||
fprintf(stderr, "allocated %d megs and %d bytes so far\n",
|
||||
(int) pcb->allocated_megs,
|
||||
(int) pcb->allocated_bytes);
|
||||
#endif
|
||||
}
|
||||
|
||||
int required_space = align_to_page(used_space + 2*pagesize);
|
||||
if(required_space < minimum_heap_size){
|
||||
required_space = minimum_heap_size;
|
||||
}
|
||||
char* old_heap = pcb->heap_base;
|
||||
int old_size = (int)pcb->heap_size;
|
||||
char* old_string_pages = pcb->string_pages;
|
||||
pcb->string_pages = 0;
|
||||
char* new_heap = allocate_unprotected_space(required_space);
|
||||
pcb->allocation_pointer = new_heap;
|
||||
pcb->allocation_redline = new_heap + required_space - 2 * pagesize;
|
||||
pcb->heap_base = new_heap;
|
||||
pcb->heap_size = (char*) required_space;
|
||||
copy_roots(pcb);
|
||||
char** p = (char**) new_heap;
|
||||
while(p != (char**) pcb->allocation_pointer){
|
||||
*p = move_object(*p, pcb);
|
||||
p++;
|
||||
}
|
||||
deallocate_unprotected_space(old_heap, old_size);
|
||||
deallocate_string_pages(old_string_pages);
|
||||
return pcb;
|
||||
}
|
||||
|
||||
#define fixnump(x) ((((int)(x)) & fx_mask) == fx_tag)
|
||||
#define closurep(x) ((((int)(x)) & closure_mask) == closure_tag)
|
||||
#define immediatep(x) ((((int)(x)) & 7) == 7)
|
||||
#define tagof(x) (((int) (x)) & 7)
|
||||
#define ref(x,t) (*((char**)(((char*)(x))+((int)(t)))))
|
||||
#define align(x) ((((x)+object_alignment-1)>>align_shift)<<align_shift)
|
||||
|
||||
typedef struct page_t{
|
||||
char* base;
|
||||
char* end;
|
||||
struct page_t* next;
|
||||
} page_t;
|
||||
|
||||
static page_t* make_page_t(){
|
||||
page_t* p = malloc(sizeof(page_t));
|
||||
if(p == NULL){
|
||||
fprintf(stderr, "failed to allocate page");
|
||||
exit(-1);
|
||||
}
|
||||
return p;
|
||||
}
|
||||
|
||||
static void deallocate_string_pages(char* old_string_pages){
|
||||
page_t* p;
|
||||
p = (page_t*) old_string_pages;
|
||||
while(p){
|
||||
deallocate_unprotected_space(p->base, p->end - p->base);
|
||||
p=p->next;
|
||||
}
|
||||
p = (page_t*) old_string_pages;
|
||||
while(p){
|
||||
page_t* n = p->next;
|
||||
free(p);
|
||||
p = n;
|
||||
}
|
||||
}
|
||||
|
||||
#if 0
|
||||
static char* extend_pointer_ap(pcb_t* pcb, int size){
|
||||
if(pcb->pointer_base){
|
||||
page_t* p = make_page_t();
|
||||
p->base = pcb->pointer_base;
|
||||
p->end = pcb->pointer_ap;
|
||||
p->next = (page_t*) pcb->pointer_pages;
|
||||
pcb->pointer_pages = (char*) p;
|
||||
}
|
||||
char* ap = allocate_unprotected_space(size);
|
||||
pcb->pointer_base = ap;
|
||||
pcb->pointer_ap = ap;
|
||||
pcb->pointer_eap = ap + size;
|
||||
return ap;
|
||||
}
|
||||
#endif
|
||||
|
||||
static char* alloc_large_string(pcb_t* pcb, int size){
|
||||
char* ap = allocate_unprotected_space(size);
|
||||
page_t* p = make_page_t();
|
||||
p->base = ap;
|
||||
p->end = ap+size;
|
||||
p->next = (page_t*) pcb->string_pages;
|
||||
pcb->string_pages = (char*) p;
|
||||
return ap;
|
||||
}
|
||||
|
||||
static char* extend_string_ap(pcb_t* pcb, int size){
|
||||
if(pcb->string_base){
|
||||
page_t* p = make_page_t();
|
||||
p->base = pcb->string_base;
|
||||
p->end = pcb->string_ap;
|
||||
p->next = (page_t*) pcb->string_pages;
|
||||
pcb->string_pages = (char*) p;
|
||||
}
|
||||
char* ap = allocate_unprotected_space(size);
|
||||
pcb->string_base = ap;
|
||||
pcb->string_ap = ap;
|
||||
pcb->string_eap = ap + size;
|
||||
return ap;
|
||||
}
|
||||
|
||||
static char* move_string(char* s, pcb_t* pcb){
|
||||
int len = (int) ref(s, -string_tag);
|
||||
int sz = align((len>>fx_shift)+disp_string_data+1);
|
||||
if(sz < pagesize){
|
||||
char* ap = pcb->string_ap;
|
||||
char* nap = ap + sz;
|
||||
if(nap > pcb->string_eap){
|
||||
ap = extend_string_ap(pcb, pagesize);
|
||||
pcb->string_eap = ap + pagesize;
|
||||
nap = ap + sz;
|
||||
}
|
||||
pcb->string_ap = nap;
|
||||
memcpy(ap, s-string_tag, sz);
|
||||
ref(s,-string_tag) = (char*)-1;
|
||||
ref(s,wordsize-string_tag) = ap+string_tag;
|
||||
return ap + string_tag;
|
||||
}
|
||||
else {
|
||||
char* ap = alloc_large_string(pcb, sz);
|
||||
memcpy(ap, s-string_tag, sz);
|
||||
ref(s,-string_tag) = (char*)-1;
|
||||
ref(s,wordsize-string_tag) = ap+string_tag;
|
||||
return ap + string_tag;
|
||||
}
|
||||
}
|
||||
|
||||
static char* move_pointers(char* x, pcb_t* pcb, int size, int tag){
|
||||
int sz = align(size);
|
||||
char* ap = pcb->allocation_pointer;
|
||||
char* nap = ap + sz;
|
||||
pcb->allocation_pointer = nap;
|
||||
ref(nap, -wordsize) = 0;
|
||||
memcpy(ap, x, size);
|
||||
ref(x,0) = (char*)-1;
|
||||
ref(x,wordsize) = ap + tag;
|
||||
return ap + tag;
|
||||
}
|
||||
|
||||
|
||||
static char* move_object(char* x, pcb_t* pcb){
|
||||
if(fixnump(x)){
|
||||
return x;
|
||||
}
|
||||
else if(immediatep(x)){
|
||||
return x;
|
||||
}
|
||||
else {
|
||||
int tag = tagof(x);
|
||||
char* fst = ref(x, -tag);
|
||||
if(fst == (char*)-1){
|
||||
return ref(x,wordsize-tag);
|
||||
}
|
||||
else if(tag == pair_tag){
|
||||
return(move_pointers(x-tag, pcb, pair_size, tag));
|
||||
}
|
||||
else if(tag == closure_tag){
|
||||
assert(ref(fst, -2*wordsize) == 0);
|
||||
int size = (int) ref(fst, -wordsize);
|
||||
assert(fixnump(size));
|
||||
assert(size > 0);
|
||||
return(move_pointers(x-tag, pcb, size, tag));
|
||||
}
|
||||
else if(tag == symbol_tag){
|
||||
return(move_pointers(x-tag, pcb, symbol_size, tag));
|
||||
}
|
||||
else if(tag == vector_tag){
|
||||
return(move_pointers(x-tag, pcb, disp_vector_data + (int)fst, tag));
|
||||
}
|
||||
else if(tag == string_tag){
|
||||
return(move_string(x, pcb));
|
||||
}
|
||||
else {
|
||||
fprintf(stderr, "here tag=%d\n", tag);
|
||||
exit(-1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static void copy_roots(pcb_t* pcb){
|
||||
/* first, the constants */
|
||||
root_t* r = (root_t*)pcb->roots;
|
||||
while(r){
|
||||
int n = r->count;
|
||||
#if 0
|
||||
fprintf(stderr, "copying root 0x%08x (%d objs) \n", (int)r, n);
|
||||
#endif
|
||||
char** f = r->start;
|
||||
int i;
|
||||
for(i=0; i<n; i++){
|
||||
f[i] = move_object(f[i], pcb);
|
||||
}
|
||||
r = r->next;
|
||||
}
|
||||
|
||||
/* next, the pcb-primitives */
|
||||
char** fst = &pcb->scheme_objects;
|
||||
char** end = &pcb->scheme_objects_end;
|
||||
fst++;
|
||||
while(fst < end){
|
||||
*fst = move_object(*fst, pcb);
|
||||
fst++;
|
||||
}
|
||||
|
||||
/* next, the stack */
|
||||
#define FRAMESIZE_OFFSET -9
|
||||
char* fp = pcb->stack_extent;
|
||||
char* stack_base = pcb->scheme_stack;
|
||||
while(fp != stack_base){
|
||||
assert(fp < stack_base);
|
||||
#if 0
|
||||
fprintf(stderr, "copying frame at 0x%08x of 0x%08x\n",
|
||||
(int)fp, (int)stack_base);
|
||||
#endif
|
||||
char* rp = ref(fp, 0);
|
||||
#if 0
|
||||
fprintf(stderr, "return-point = 0x%08x\n", (int)rp);
|
||||
#endif
|
||||
int framesize = (int) ref(rp, FRAMESIZE_OFFSET); /* UGLY */
|
||||
assert(fixnump(framesize));
|
||||
assert(framesize >= 0);
|
||||
if(framesize > 0){
|
||||
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
|
||||
char* mask = rp + FRAMESIZE_OFFSET - bytes_in_mask;
|
||||
fp = fp + framesize;
|
||||
char** fpp = (char**) fp;
|
||||
int i;
|
||||
for(i=0; i<bytes_in_mask; i++){
|
||||
unsigned char m = mask[i];
|
||||
if(m){
|
||||
if (m & 0x01) {
|
||||
fpp[0] = move_object(fpp[0], pcb);
|
||||
}
|
||||
if (m & 0x02) {
|
||||
fpp[-1] = move_object(fpp[-1], pcb);
|
||||
}
|
||||
if (m & 0x04) {
|
||||
fpp[-2] = move_object(fpp[-2], pcb);
|
||||
}
|
||||
if (m & 0x08) {
|
||||
fpp[-3] = move_object(fpp[-3], pcb);
|
||||
}
|
||||
if (m & 0x10) {
|
||||
fpp[-4] = move_object(fpp[-4], pcb);
|
||||
}
|
||||
if (m & 0x20) {
|
||||
fpp[-5] = move_object(fpp[-5], pcb);
|
||||
}
|
||||
if (m & 0x40) {
|
||||
fpp[-6] = move_object(fpp[-6], pcb);
|
||||
}
|
||||
if (m & 0x80) {
|
||||
fpp[-7] = move_object(fpp[-7], pcb);
|
||||
}
|
||||
}
|
||||
fpp -= 8;
|
||||
}
|
||||
}
|
||||
else if(framesize == 0){
|
||||
framesize = (int)ref(fp, wordsize);
|
||||
assert(fixnump(framesize));
|
||||
assert(framesize > 0);
|
||||
#if 0
|
||||
/* move cp */
|
||||
{
|
||||
char* cp = ref(fp, 2*wordsize);
|
||||
assert(closurep(cp));
|
||||
ref(fp, 2*wordsize) = move_object(cp, pcb);
|
||||
}
|
||||
#endif
|
||||
fp += framesize;
|
||||
int i;
|
||||
for(i=wordsize; i<(framesize); i+=wordsize){
|
||||
ref(fp, -i) = move_object(ref(fp,-i), pcb);
|
||||
}
|
||||
}
|
||||
else {
|
||||
fprintf(stderr, "Error: framesize is %d\n", framesize);
|
||||
exit(-10);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
static char* allocate_unprotected_space(int size){
|
||||
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
|
||||
char* p = mmap(0, aligned_size,
|
||||
PROT_READ | PROT_WRITE,
|
||||
MAP_ANONYMOUS | MAP_PRIVATE,
|
||||
0, 0);
|
||||
if(p == MAP_FAILED){
|
||||
perror("allocate_unprotected_space failed to mmap");
|
||||
exit(-10);
|
||||
}
|
||||
return p;
|
||||
}
|
||||
|
||||
|
||||
static void deallocate_unprotected_space(char* p, int size){
|
||||
int status;
|
||||
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
|
||||
status = munmap(p, aligned_size);
|
||||
if(status != 0){
|
||||
perror("deallocate_unprotected_space failed to unmap");
|
||||
exit(-10);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
#ifndef COLLECT_H
|
||||
#define COLLECT_H
|
||||
#include "scheme.h"
|
||||
void S_add_roots(pcb_t*, int*);
|
||||
void S_check_roots(pcb_t*, int*);
|
||||
#endif
|
|
@ -1,572 +0,0 @@
|
|||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <sys/mman.h>
|
||||
#include <assert.h>
|
||||
#include "scheme.h"
|
||||
|
||||
typedef struct root_t{
|
||||
int count;
|
||||
char** start;
|
||||
struct root_t* next;
|
||||
} root_t;
|
||||
|
||||
void S_add_roots(pcb_t* pcb, int* f){
|
||||
int n = *f;
|
||||
if(n == 0) return;
|
||||
root_t* t = malloc(sizeof(root_t));
|
||||
if(t == NULL){
|
||||
fprintf(stderr, "Error mallocing\n");
|
||||
exit(-1);
|
||||
}
|
||||
t->count = n;
|
||||
t->start = (char**)(f+1);
|
||||
t->next = (root_t*) pcb->roots;
|
||||
pcb->roots = (char*) t;
|
||||
int i;
|
||||
for(i=1; i<=n; i++){
|
||||
assert(f[i] == 0);
|
||||
}
|
||||
}
|
||||
|
||||
void S_check_roots(pcb_t* pcb, int* f){
|
||||
int n = *f;
|
||||
int i;
|
||||
for(i=1; i<=n; i++){
|
||||
assert(f[i] != 0);
|
||||
}
|
||||
}
|
||||
|
||||
/* S_collect is called from scheme under the following conditions:
|
||||
* 1. An attempt is made to allocate a small object and the ap is above
|
||||
* the red line.
|
||||
* 2. The current frame of the call is dead, so, upon return from S_collect,
|
||||
* the caller returns to its caller.
|
||||
* 3. The frame-pointer of the caller to S_collect is saved at
|
||||
* pcb->stack_extent. No variables are live at that frame except for
|
||||
* the return point (at *(pcb->stack_extent)).
|
||||
* 4. S_collect must return a new ap (in pcb->allocation_pointer) that has
|
||||
* at least 2 pages of memory free.
|
||||
* 5. S_collect must also update pcb->allocaton_red_line to be 2 pages below
|
||||
* the real end of heap.
|
||||
* 6. S_collect should not move the stack.
|
||||
*/
|
||||
|
||||
#define pagesize 4096
|
||||
#define minimum_heap_size (pagesize * 1024 * 4)
|
||||
#define maximum_heap_size (pagesize * 1024 * 8)
|
||||
#define minimum_stack_size (pagesize * 128)
|
||||
#define align_to_page(x) (((x)/pagesize)*pagesize)
|
||||
static char* allocate_unprotected_space(int size);
|
||||
static void deallocate_unprotected_space(char* p, int size);
|
||||
static void deallocate_string_pages(char*);
|
||||
static void copy_roots(pcb_t* pcb);
|
||||
static char* move_object(char* x, pcb_t* pcb);
|
||||
|
||||
pcb_t* S_collect(int req, pcb_t* pcb){
|
||||
#if 0
|
||||
fprintf(stderr, "S_collect entry %d (pcb=0x%08x)\n", req, (int)pcb);
|
||||
#endif
|
||||
char* heap_base = pcb->heap_base;
|
||||
#if 0
|
||||
int heap_size = (int)pcb->heap_size;
|
||||
fprintf(stderr, "heapsize=0x%08x (0x%08x .. 0x%08x)\n",
|
||||
heap_size,
|
||||
(int) heap_base,
|
||||
(int) (heap_base + heap_size - 1));
|
||||
#endif
|
||||
int used_space = (int)(pcb->allocation_pointer - heap_base);
|
||||
{
|
||||
int bytes = (int) pcb->allocated_bytes + (used_space & 0xFFFFF);
|
||||
pcb->allocated_megs += (bytes >> 20);
|
||||
pcb->allocated_bytes = (char*) (bytes & 0xFFFFF);
|
||||
#if 0
|
||||
fprintf(stderr, "allocated %d megs and %d bytes so far\n",
|
||||
(int) pcb->allocated_megs,
|
||||
(int) pcb->allocated_bytes);
|
||||
#endif
|
||||
}
|
||||
|
||||
int required_space = align_to_page(used_space + 2 * req + 2 * pagesize);
|
||||
if(required_space < minimum_heap_size){
|
||||
required_space = minimum_heap_size;
|
||||
}
|
||||
if(required_space > maximum_heap_size){
|
||||
fprintf(stderr, "Maximum heapsize exceeded\n");
|
||||
exit(-1);
|
||||
}
|
||||
char* old_heap = pcb->heap_base;
|
||||
int old_size = (int)pcb->heap_size;
|
||||
char* old_string_pages = pcb->string_pages;
|
||||
pcb->string_pages = 0;
|
||||
char* new_heap = allocate_unprotected_space(maximum_heap_size);
|
||||
pcb->allocation_pointer = new_heap;
|
||||
pcb->allocation_redline = new_heap + maximum_heap_size - 2 * pagesize;
|
||||
pcb->heap_base = new_heap;
|
||||
pcb->heap_size = (char*) maximum_heap_size;
|
||||
copy_roots(pcb);
|
||||
char** p = (char**) new_heap;
|
||||
while(p != (char**) pcb->allocation_pointer){
|
||||
*p = move_object(*p, pcb);
|
||||
p++;
|
||||
}
|
||||
deallocate_unprotected_space(old_heap, old_size);
|
||||
deallocate_string_pages(old_string_pages);
|
||||
{
|
||||
int free_space =
|
||||
(int)pcb->allocation_redline - (int)pcb->allocation_pointer;
|
||||
int diff = align_to_page(free_space - minimum_heap_size);
|
||||
if(diff > 0){
|
||||
deallocate_unprotected_space(
|
||||
pcb->heap_base + (int)pcb->heap_size - diff,
|
||||
diff);
|
||||
pcb->allocation_redline -= diff;
|
||||
pcb->heap_size -= diff;
|
||||
}
|
||||
}
|
||||
#if 0
|
||||
fprintf(stderr, "ap=0x%08x limit=0x%08x\n",
|
||||
(int)pcb->allocation_pointer,
|
||||
(int)pcb->heap_base+(int)pcb->heap_size-wordsize);
|
||||
#endif
|
||||
return pcb;
|
||||
}
|
||||
|
||||
#define fixnump(x) ((((int)(x)) & fx_mask) == fx_tag)
|
||||
#define closurep(x) ((((int)(x)) & closure_mask) == closure_tag)
|
||||
#define immediatep(x) ((((int)(x)) & 7) == 7)
|
||||
#define tagof(x) (((int) (x)) & 7)
|
||||
#define ref(x,t) (*((char**)(((char*)(x))+((int)(t)))))
|
||||
#define align(x) ((((x)+object_alignment-1)>>align_shift)<<align_shift)
|
||||
|
||||
typedef struct page_t{
|
||||
char* base;
|
||||
char* end;
|
||||
struct page_t* next;
|
||||
} page_t;
|
||||
|
||||
static page_t* make_page_t(){
|
||||
page_t* p = malloc(sizeof(page_t));
|
||||
if(p == NULL){
|
||||
fprintf(stderr, "failed to allocate page");
|
||||
exit(-1);
|
||||
}
|
||||
return p;
|
||||
}
|
||||
|
||||
static void deallocate_string_pages(char* old_string_pages){
|
||||
page_t* p;
|
||||
p = (page_t*) old_string_pages;
|
||||
while(p){
|
||||
deallocate_unprotected_space(p->base, p->end - p->base);
|
||||
p=p->next;
|
||||
}
|
||||
p = (page_t*) old_string_pages;
|
||||
while(p){
|
||||
page_t* n = p->next;
|
||||
free(p);
|
||||
p = n;
|
||||
}
|
||||
}
|
||||
|
||||
#if 0
|
||||
static char* extend_pointer_ap(pcb_t* pcb, int size){
|
||||
if(pcb->pointer_base){
|
||||
page_t* p = make_page_t();
|
||||
p->base = pcb->pointer_base;
|
||||
p->end = pcb->pointer_ap;
|
||||
p->next = (page_t*) pcb->pointer_pages;
|
||||
pcb->pointer_pages = (char*) p;
|
||||
}
|
||||
char* ap = allocate_unprotected_space(size);
|
||||
pcb->pointer_base = ap;
|
||||
pcb->pointer_ap = ap;
|
||||
pcb->pointer_eap = ap + size;
|
||||
return ap;
|
||||
}
|
||||
#endif
|
||||
|
||||
static char* alloc_large_string(pcb_t* pcb, int size){
|
||||
char* ap = allocate_unprotected_space(size);
|
||||
page_t* p = make_page_t();
|
||||
p->base = ap;
|
||||
p->end = ap+size;
|
||||
p->next = (page_t*) pcb->string_pages;
|
||||
pcb->string_pages = (char*) p;
|
||||
return ap;
|
||||
}
|
||||
|
||||
static char* extend_string_ap(pcb_t* pcb, int size){
|
||||
if(pcb->string_base){
|
||||
page_t* p = make_page_t();
|
||||
p->base = pcb->string_base;
|
||||
p->end = pcb->string_ap;
|
||||
p->next = (page_t*) pcb->string_pages;
|
||||
pcb->string_pages = (char*) p;
|
||||
}
|
||||
char* ap = allocate_unprotected_space(size);
|
||||
pcb->string_base = ap;
|
||||
pcb->string_ap = ap;
|
||||
pcb->string_eap = ap + size;
|
||||
return ap;
|
||||
}
|
||||
|
||||
static char* move_string(char* s, pcb_t* pcb){
|
||||
int len = (int) ref(s, -string_tag);
|
||||
int sz = align((len>>fx_shift)+disp_string_data+1);
|
||||
if(sz < pagesize){
|
||||
char* ap = pcb->string_ap;
|
||||
char* nap = ap + sz;
|
||||
if(nap > pcb->string_eap){
|
||||
ap = extend_string_ap(pcb, pagesize);
|
||||
pcb->string_eap = ap + pagesize;
|
||||
nap = ap + sz;
|
||||
}
|
||||
pcb->string_ap = nap;
|
||||
memcpy(ap, s-string_tag, sz);
|
||||
ref(s,-string_tag) = (char*)-1;
|
||||
ref(s,wordsize-string_tag) = ap+string_tag;
|
||||
return ap + string_tag;
|
||||
}
|
||||
else {
|
||||
char* ap = alloc_large_string(pcb, sz);
|
||||
memcpy(ap, s-string_tag, sz);
|
||||
ref(s,-string_tag) = (char*)-1;
|
||||
ref(s,wordsize-string_tag) = ap+string_tag;
|
||||
return ap + string_tag;
|
||||
}
|
||||
}
|
||||
|
||||
static void munch_stack(char* fp, pcb_t* pcb, char* frame_base){
|
||||
#define FRAMESIZE_OFFSET -9
|
||||
while(fp != frame_base){
|
||||
assert(fp < frame_base);
|
||||
#if 0
|
||||
fprintf(stderr, "copying frame at 0x%08x of 0x%08x\n",
|
||||
(int)fp, (int)stack_base);
|
||||
#endif
|
||||
char* rp = ref(fp, 0);
|
||||
#if 0
|
||||
fprintf(stderr, "return-point = 0x%08x\n", (int)rp);
|
||||
#endif
|
||||
int framesize = (int) ref(rp, FRAMESIZE_OFFSET); /* UGLY */
|
||||
assert(fixnump(framesize));
|
||||
assert(framesize >= 0);
|
||||
if(framesize > 0){
|
||||
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
|
||||
char* mask = rp + FRAMESIZE_OFFSET - bytes_in_mask;
|
||||
fp = fp + framesize;
|
||||
char** fpp = (char**) fp;
|
||||
int i;
|
||||
for(i=0; i<bytes_in_mask; i++){
|
||||
unsigned char m = mask[i];
|
||||
if(m){
|
||||
if (m & 0x01) {
|
||||
fpp[0] = move_object(fpp[0], pcb);
|
||||
}
|
||||
if (m & 0x02) {
|
||||
fpp[-1] = move_object(fpp[-1], pcb);
|
||||
}
|
||||
if (m & 0x04) {
|
||||
fpp[-2] = move_object(fpp[-2], pcb);
|
||||
}
|
||||
if (m & 0x08) {
|
||||
fpp[-3] = move_object(fpp[-3], pcb);
|
||||
}
|
||||
if (m & 0x10) {
|
||||
fpp[-4] = move_object(fpp[-4], pcb);
|
||||
}
|
||||
if (m & 0x20) {
|
||||
fpp[-5] = move_object(fpp[-5], pcb);
|
||||
}
|
||||
if (m & 0x40) {
|
||||
fpp[-6] = move_object(fpp[-6], pcb);
|
||||
}
|
||||
if (m & 0x80) {
|
||||
fpp[-7] = move_object(fpp[-7], pcb);
|
||||
}
|
||||
}
|
||||
fpp -= 8;
|
||||
}
|
||||
}
|
||||
else if(framesize == 0){
|
||||
framesize = (int)ref(fp, wordsize);
|
||||
assert(fixnump(framesize));
|
||||
assert(framesize > 0);
|
||||
#if 0
|
||||
/* move cp */
|
||||
{
|
||||
char* cp = ref(fp, 2*wordsize);
|
||||
assert(closurep(cp));
|
||||
ref(fp, 2*wordsize) = move_object(cp, pcb);
|
||||
}
|
||||
#endif
|
||||
fp += framesize;
|
||||
int i;
|
||||
for(i=wordsize; i<(framesize); i+=wordsize){
|
||||
ref(fp, -i) = move_object(ref(fp,-i), pcb);
|
||||
}
|
||||
}
|
||||
else {
|
||||
fprintf(stderr, "Error: framesize is %d\n", framesize);
|
||||
exit(-10);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static char* move_stack(char* s, pcb_t* pcb, int sz){
|
||||
char* ns;
|
||||
int asz = align(sz);
|
||||
if(asz < pagesize){
|
||||
char* ap = pcb->string_ap;
|
||||
char* nap = ap + asz;
|
||||
if(nap > pcb->string_eap){
|
||||
ap = extend_string_ap(pcb, pagesize);
|
||||
pcb->string_eap = ap + pagesize;
|
||||
nap = ap + asz;
|
||||
}
|
||||
pcb->string_ap = nap;
|
||||
ns = ap;
|
||||
}
|
||||
else {
|
||||
ns = alloc_large_string(pcb, asz);
|
||||
}
|
||||
memcpy(ns, s, sz);
|
||||
munch_stack(ns, pcb, ns+sz);
|
||||
return ns;
|
||||
}
|
||||
|
||||
|
||||
static char* move_pointers(char* x, pcb_t* pcb, int size, int tag){
|
||||
int sz = align(size);
|
||||
char* ap = pcb->allocation_pointer;
|
||||
char* nap = ap + sz;
|
||||
pcb->allocation_pointer = nap;
|
||||
ref(nap, -wordsize) = 0;
|
||||
memcpy(ap, x, size);
|
||||
ref(x,0) = (char*)-1;
|
||||
ref(x,wordsize) = ap + tag;
|
||||
return ap + tag;
|
||||
}
|
||||
|
||||
|
||||
static char* move_continuation(char* x, pcb_t* pcb){
|
||||
int sz = (int) ref(x, disp_continuation_size);
|
||||
char* top = ref(x, disp_continuation_top);
|
||||
char* r = move_pointers(x, pcb, continuation_size, vector_tag);
|
||||
ref(r, disp_continuation_top - vector_tag) = move_stack(top, pcb, sz);
|
||||
return r;
|
||||
}
|
||||
|
||||
static char* move_object(char* x, pcb_t* pcb){
|
||||
if(fixnump(x)){
|
||||
return x;
|
||||
}
|
||||
else if(immediatep(x)){
|
||||
return x;
|
||||
}
|
||||
else {
|
||||
int tag = tagof(x);
|
||||
char* fst = ref(x, -tag);
|
||||
if(fst == (char*)-1){
|
||||
return ref(x,wordsize-tag);
|
||||
}
|
||||
else if(tag == pair_tag){
|
||||
return(move_pointers(x-tag, pcb, pair_size, tag));
|
||||
}
|
||||
else if(tag == closure_tag){
|
||||
assert(ref(fst, -2*wordsize) == 0);
|
||||
int size = (int) ref(fst, -wordsize);
|
||||
assert(fixnump(size));
|
||||
assert(size > 0);
|
||||
return (move_pointers(x-tag, pcb, size, tag));
|
||||
}
|
||||
else if(tag == symbol_tag){
|
||||
return (move_pointers(x-tag, pcb, symbol_size, tag));
|
||||