conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* nothing much

This commit is contained in:
Abdulaziz Ghuloum 2007-02-13 02:05:58 -05:00
parent 826adfe9dd
commit a123a77bbc
6 changed files with 167 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/geninstr/gen.pl
View File

@ -48,7 +48,7 @@ sub gen3{
}
}
gen1 "addl \$27, 12(r1)\n";
gen1 "addl \$0x12345678, 7(r1)\n";
#gen1 "movb \$0, 4(r1)\n";
#gen1 "movb -2(r1), %ah\n";

16
src/geninstr/tmp.s
View File

@ -1,9 +1,9 @@
.text
addl $27, 12(%eax)
addl $27, 12(%ecx)
addl $27, 12(%edx)
addl $27, 12(%ebx)
addl $27, 12(%esp)
addl $27, 12(%ebp)
addl $27, 12(%esi)
addl $27, 12(%edi)
addl $0x12345678, 7(%eax)
addl $0x12345678, 7(%ecx)
addl $0x12345678, 7(%edx)
addl $0x12345678, 7(%ebx)
addl $0x12345678, 7(%esp)
addl $0x12345678, 7(%ebp)
addl $0x12345678, 7(%esi)
addl $0x12345678, 7(%edi)

BIN
src/ikarus.boot
View File

Binary file not shown.

124
src/libaltcogen.ss
View File

@ -124,7 +124,7 @@
[vector? p]
[null? p]
[eof-object? p]
;[eof-object v]
[eof-object v]
[procedure? p]
[symbol? p]
[boolean? p]
@ -140,6 +140,9 @@
[cons v]
[$car v]
[$cdr v]
[$fx+ v]
[$fxadd1 v]
[$fxsll v]
[$fxsra v]
[$fxlogand v]
@ -152,14 +155,23 @@
[$fx= p]
;[$char<= p]
;[$char= p]
;[$char->fixnum v]
[$char<= p]
[$char= p]
[$char->fixnum v]
[$vector-ref v]
[$vector-set! e]
[$set-symbol-value! e]
[$record v]
[$record/rtd? p]
[$record-ref v]
[$record-set! e]
[$record? p]
[$record-rtd v]
[$make-record v]
;;; ports
[output-port? p]
[input-port? p]
@ -184,6 +196,7 @@
list list*
not
car cdr
top-level-value
))
(define (must-open-code? x)
(and (assq x core-prims) #t))
@ -556,6 +569,7 @@
(define who 'specify-representation)
;;;
(define fixnum-scale 4)
(define fixnum-shift 2)
(define fixnum-tag 0)
(define fixnum-mask 3)
(define pcb-dirty-vector-offset 28)
@ -627,7 +641,7 @@
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x
(- disp-symbol-value symbol-tag)))]
[($vector-set!)
[($vector-set! $record-set!)
(let ([x (Value (car arg*))]
[i (cadr arg*)]
[v (Value (caddr arg*))])
@ -652,7 +666,7 @@
(error who "appcall not supported yet")]
[(mvcall rator x)
(make-mvcall (Value rator) (Clambda x Effect))]
[else (error who "invalid pred expr ~s" x)]))
[else (error who "invalid effect expr ~s" x)]))
;;;
(define (tag-test x mask tag)
(if mask
@ -703,6 +717,26 @@
[(vector?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag fixnum-mask fixnum-tag)]
[($record?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag vector-mask vector-tag)]
[(input-port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag #f input-port-tag)]
[(output-port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag #f output-port-tag)]
[(port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag port-mask port-tag)]
[($record/rtd?)
(tbind ([t (Value (car arg*))])
(make-conditional
(tag-test t vector-mask vector-tag)
(prm '=
(prm 'mref t (K (- vector-tag)))
(Value (cadr arg*)))
(make-constant #f)))]
[(output-port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag #f output-port-tag)]
@ -718,15 +752,15 @@
(prm 'mref pcr (K 12)) ;;; PCB FRAME-BASE
(K (- wordsize)))
fpr)]
[($fx=)
[($fx= $char=)
(prm '= (Value (car arg*)) (Value (cadr arg*)))]
[($fx<)
[($fx< $char<)
(prm '< (Value (car arg*)) (Value (cadr arg*)))]
[($fx>)
[($fx> $char>)
(prm '> (Value (car arg*)) (Value (cadr arg*)))]
[($fx<=)
[($fx<= $char<=)
(prm '<= (Value (car arg*)) (Value (cadr arg*)))]
[($fx>=)
[($fx>= $char>=)
(prm '>= (Value (car arg*)) (Value (cadr arg*)))]
[else (error who "pred prim ~a not supported" op)])]
[(mvcall rator x)
@ -755,6 +789,7 @@
[(primcall op arg*)
(case op
[(void) (K void-object)]
[(eof-object) (K eof)]
[($car)
(prm 'mref (Value (car arg*)) (K (- disp-car pair-tag)))]
[($cdr)
@ -777,6 +812,61 @@
(Value label))
t))]
[else (err x)]))]
[($record)
(let ([rtd (car arg*)] [v* (map Value (cdr arg*))])
(unless (constant? rtd)
(error who "invalid rtd ~s for $record" rtd))
(let ([t* (map (lambda (x) (unique-var 'v)) v*)])
(make-bind t* v*
(tbind ([t (prm 'alloc
(K (+ disp-record-data
(* (length v*) wordsize)))
(K vector-tag))])
(seq*
(prm 'mset! t
(K (- disp-record-rtd vector-tag))
(Value rtd))
(let f ([t* t*] [i (- disp-record-data vector-tag)])
(cond
[(null? t*) t]
[else
(make-seq
(prm 'mset! t (K i) (car t*))
(f (cdr t*) (+ i wordsize)))])))))))]
[($make-record)
(let ([rtd (car arg*)] [len (cadr arg*)])
(tbind ([rtd rtd])
(record-case len
[(constant i)
(unless (fixnum? i)
(error who "invalid make-rec ~s" len))
(tbind ([t (prm 'alloc
(K (align (+ (* i wordsize)
disp-record-data)))
(K vector-tag))])
(seq*
(prm 'mset! t
(K (- disp-record-rtd vector-tag))
rtd)
t))]
[else
(tbind ([len
(prm 'sll
(prm 'sra
(prm 'int+ (Value len)
(K (sub1
object-alignment)))
(K align-shift))
(K align-shift))])
(tbind ([t (prm 'alloc len (K vector-tag))])
(seq*
(prm 'mset! t
(K (- disp-record-rtd vector-tag))
rtd)
t)))])))]
[($record-rtd)
(prm 'mref (Value (car arg*))
(K (- disp-record-rtd vector-tag)))]
[(cons)
(tbind ([a (Value (car arg*))]
[d (Value (cadr arg*))])
@ -785,6 +875,12 @@
(prm 'mset! t (K (- disp-car pair-tag)) a)
(prm 'mset! t (K (- disp-cdr pair-tag)) d)
t)))]
[($fxadd1)
(prm 'int+ (Value (car arg*)) (K (* 1 fixnum-scale)))]
[($fxsub1)
(prm 'int+ (Value (car arg*)) (K (* -1 fixnum-scale)))]
[($fx+)
(prm 'int+ (Value (car arg*)) (Value (cadr arg*)))]
[($fxmodulo)
(tbind ([a (Value (car arg*))]
[b (Value (cadr arg*))])
@ -811,6 +907,10 @@
[else (error who "nonconst arg to fxsra ~s" c)]))]
[($fxlogand)
(prm 'logand (Value (car arg*)) (Value (cadr arg*)))]
[($char->fixnum)
(prm 'sra
(Value (car arg*))
(K (- char-shift fixnum-shift)))]
[($current-frame) ;; PCB NEXT-CONTINUATION
(prm 'mref pcr (K 20))]
[($seal-frame-and-call)
@ -863,7 +963,7 @@
(K (+ (- disp-closure-data closure-tag)
(* i wordsize))))]
[else (err x)]))]
[($vector-ref)
[($vector-ref $record-ref)
(let ([a0 (car arg*)] [a1 (cadr arg*)])
(record-case a1
[(constant i)

66
src/libintelasm.ss
View File

@ -365,12 +365,41 @@
(error 'CODEdi "unsupported2")]
[else (error 'CODEdi "unhandled ~s" disp)])))))
; 81 /0 id ADD r/m32,imm32 Valid Valid Add imm32 to
(define (CODE/r c /?)
(lambda (dst ac)
(cond
[(mem? dst)
(with-args dst
(lambda (a0 a1)
(cond
[(and (imm8? a0) (reg? a1))
(CODE c (ModRM 1 /? a1 (IMM8 a0 ac)))]
[else (error 'CODE/r "unhandled ~s ~s" a0 a1)])))]
[else (error 'CODE/r "unhandled ~s" dst)])))
(define CODEid
(lambda (c /? n disp ac)
(with-args disp
(lambda (a1 a2)
(cond
[(and (reg? a1) (reg? a2))
(error 'CODEid "unsupported1 ~s" disp)]
[(and (imm? a1) (reg? a2))
(error 'CODEid "unsupported2")
(CODErri c /? a2 a1 (IMM32 n ac))]
[(and (imm? a2) (reg? a1))
(error 'CODEid "unsupported3")
(CODErri c /? a1 a2 (IMM32 n ac))]
[(and (imm? a1) (imm? a2))
(error 'CODEid "unsupported4")]
[else (error 'CODEid "unhandled ~s" disp)])))))
(define CODEdi8
(lambda (c disp n ac)
(lambda (c /? disp n ac)
(with-args disp
(lambda (i r)
(CODErri c '/0 r i (IMM8 n ac))))))
(CODErri c /? r i (IMM8 n ac))))))
(define *cogen* (gensym "*cogen*"))
@ -411,21 +440,6 @@
(error 'convert-instruction "incorrect args in ~s" a))])))]
[else (error 'convert-instruction "unknown instruction in ~s" a)]))
;;; instr/null is for 1-byte instructions that take no arguments
;(define (instr/null code ac)
; (cons code ac))
;(define (instr/ir arg1 arg2 ac ircode)
; (CODE+r ircode arg2 (IMM32 arg1 ac)))
;
;(define (instr/im arg1 arg2 ac imcode)
; (error 'instr/im "not implemented"))
;
;(define (instr/rr arg1 arg2 ac rrcode)
; (CODErr rrcode arg1 arg2 ac))
;
;(define (instr/rm arg1 arg2 ac rmcode)
; (CODErd rmcode arg1 arg2 ac))
(define (instr/2 arg1 arg2 ac ircode imcode rrcode rmcode mrcode)
@ -470,7 +484,7 @@
[(movl src dst) (instr/2 src dst ac #xB8 #xC7 #x89 #x89 #x8B)]
[(movb src dst)
(cond
[(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 dst src ac)]
[(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 '/0 dst src ac)]
[(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)]
[(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)]
[else (error who "invalid ~s" instr)])]
@ -487,7 +501,11 @@
[(and (mem? src) (reg? dst))
(CODErd #x03 dst src ac)]
[(and (imm? src) (mem? dst))
(CODEdi #x81 '/0 dst src ac)]
; (printf "addl ~s ~s\n" src dst)
; (printf "=> ~s\n" ((CODE/r #x81 '/0) dst (IMM32 src '())))
((CODE/r #x81 '/0) dst (IMM32 src ac))]
[(and (reg? src) (mem? dst))
(CODErd #x81 src dst ac)]
[else (error who "invalid ~s" instr)])]
[(subl src dst)
(cond
@ -508,6 +526,10 @@
(CODE #xD1 (ModRM 3 '/4 dst ac))]
[(and (imm8? src) (reg? dst))
(CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))]
[(and (imm8? src) (mem? dst))
(printf "sall ~s ~s\n" src dst)
(printf "=> ~s\n" ((CODE/r #xC1 '/4) dst (IMM8 src '())))
((CODE/r #xC1 '/4) dst (IMM8 src ac))]
[(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/4 dst ac))]
[else (error who "invalid ~s" instr)])]
@ -526,6 +548,10 @@
(CODE #xD1 (ModRM 3 '/7 dst ac))]
[(and (imm8? src) (reg? dst))
(CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))]
[(and (imm8? src) (mem? dst))
(printf "sarl ~s ~s\n" src dst)
(printf "=> ~s\n" ((CODE/r #xC1 '/7) dst (IMM8 src '())))
((CODE/r #xC1 '/7) dst (IMM8 src ac))]
[(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/7 dst ac))]
[else (error who "invalid ~s" instr)])]
@ -550,8 +576,6 @@
(CODE #x0D (IMM32 src ac))]
[(and (imm? src) (reg? dst))
(CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))]
[(and (imm? src) (mem? dst))
(CODEdi #x81 '/1 dst src ac)]
[(and (reg? src) (reg? dst))
(CODE #x09 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))

2
src/librecord.ss
View File

@ -97,7 +97,7 @@
(error 'make-record-type "fields must be a list, got ~s" fields))
(for-each verify-field fields)
(cond
[(top-level-bound? g)
[(top-level-bound? g)
(let ([rtd (top-level-value g)])
(unless (and (string=? name (record-type-name rtd))
(equal? fields (record-type-field-names rtd)))