Skip to content

Commit

Permalink
Fixed subtraction and framesize and now fib works
Browse files Browse the repository at this point in the history
  • Loading branch information
@gnuvince
gnuvince committed Aug 9, 2012
1 parent eeef52f commit 928e4f6
Showing 1 changed file with 148 additions and 22 deletions.
170 changes: 148 additions & 22 deletions gsc/_t-x86.scm
View file
Expand Up @@ -384,14 +384,15 @@

;; nat-label-ref: finds the label associated with a symbol. Creates it if
;; it doesn't exist.
;; nat-label-set!: insert or update a symbol/label association in the table.
(define (nat-label-ref cgc label-name)
(let ((x (table-ref nat-labels label-name #f)))
(if x
x
(let ((l (asm-make-label cgc label-name)))
(table-set! nat-labels label-name l)
l))))

;; nat-label-set!: insert or update a symbol/label association in the table.
(define (nat-label-set! cgc label-name val)
(table-set! nat-labels label-name val))

Expand Down Expand Up @@ -686,7 +687,7 @@
(if test-proc
(begin
(adjust-frame-size cgc jump-size)
(nat-if-then-else cgc ctx test-proc opnds true false))
(test-proc cgc ctx opnds true false))
(compiler-internal-error "test is not a procedure"))))


Expand All @@ -697,20 +698,22 @@

(define (adjust-frame-size cgc jump-size)
(let* ((targ (codegen-context-target cgc))
(offset (* (nat-target-word-width targ)
(- (codegen-context-frame-size cgc)
jump-size))))
(offset (- (codegen-context-frame-size cgc)
jump-size)))
(codegen-context-frame-size-set! cgc
(- (codegen-context-frame-size cgc) offset))
(if (not (= offset 0))
(x86-add cgc (nat-target-stack-ptr-reg targ) (x86-imm-int offset)))))
(x86-add cgc (nat-target-stack-ptr-reg targ)
(x86-imm-int (* (nat-target-word-width targ) offset))))))


(define (nat-if-then-else cgc ctx test opnds true* false*)
(let* ((targ (codegen-context-target cgc))
(true-lbl (nat-label-ref cgc (lbl->id true* (ctx-ns ctx))))
(false-lbl (nat-label-ref cgc (lbl->id false* (ctx-ns ctx)))))
(test cgc opnds)
(x86-jne cgc false-lbl)
(x86-jmp cgc true-lbl)))
;; (define (nat-if-then-else cgc ctx test opnds true* false*)
;; (let* ((targ (codegen-context-target cgc))
;; (true-lbl (nat-label-ref cgc (lbl->id true* (ctx-ns ctx))))
;; (false-lbl (nat-label-ref cgc (lbl->id false* (ctx-ns ctx)))))
;; (test cgc opnds)
;; (x86-jne cgc false-lbl)
;; (x86-jmp cgc true-lbl)))

(define (nat-close cgc parms)

Expand Down Expand Up @@ -744,7 +747,7 @@
(list 'clo? (clo? opnd))))

(define (nat-opnd cgc ctx opnd) ;; fetch GVM operand
;;(pp (classify-opnd opnd))
;; (pp (classify-opnd opnd))
(let ((targ (codegen-context-target cgc)))
(cond ((reg? opnd)
(let ((n (reg-num opnd)))
Expand Down Expand Up @@ -1120,8 +1123,8 @@

(proc-obj-test-set!
prim
(lambda (cgc opnds)
(ifjump-gen cgc opnds)))))
(lambda (cgc ctx opnds true-branch false-branch)
(ifjump-gen cgc ctx opnds true-branch false-branch)))))

(if jump-gen
(begin
Expand All @@ -1133,9 +1136,6 @@
prim
jump-gen)))))

(define (x86-prim-define-bool name proc-safe? side-effects prim-gen)
(x86-prim-define name proc-safe? side-effects prim-gen prim-gen))

(x86-prim-define "##not" #t #f
(lambda (cgc opnds loc)
(let* ((targ (codegen-context-target cgc))
Expand Down Expand Up @@ -1163,11 +1163,137 @@
(if (not (eq? translated-loc r1))
(x86-pop cgc r1))))

(lambda (cgc opnds)
(lambda (cgc ctx opnds true-branch false-branch)
;; (let* ((targ (codegen-context-target cgc))
;; (true-lbl (nat-label-ref cgc (lbl->id true* (ctx-ns ctx))))
;; (false-lbl (nat-label-ref cgc (lbl->id false* (ctx-ns ctx)))))
;; (test cgc opnds)
;; (x86-jne cgc false-lbl)
;; (x86-jmp cgc true-lbl)))

(let* ((targ (codegen-context-target cgc))
(opnd (nat-opnd cgc (make-ctx targ #f) (car opnds))))
(opnd (nat-opnd cgc (make-ctx targ #f) (car opnds)))
(true-lbl (nat-label-ref cgc (lbl->id true-branch (ctx-ns ctx))))
(false-lbl (nat-label-ref cgc (lbl->id false-branch (ctx-ns ctx)))))
(if (x86-reg? opnd)
(x86-cmp cgc opnd false)
(begin
(x86-push cgc (vector-ref (nat-target-gvm-reg-map targ) 1))
(x86-mov cgc (vector-ref (nat-target-gvm-reg-map targ) 1) opnd)
(x86-cmp cgc (vector-ref (nat-target-gvm-reg-map targ) 1) false))))))
(x86-cmp cgc (vector-ref (nat-target-gvm-reg-map targ) 1) false)
(x86-pop cgc (vector-ref (nat-target-gvm-reg-map targ) 1))))
(x86-jne cgc false-lbl)
(x86-jmp cgc true-lbl))))


;; TODO: handle 0-ary, 1-ary and >2-ary cases
(x86-prim-define "##fx+" #f #f
(lambda (cgc opnds loc)
(let* ((targ (codegen-context-target cgc))
(ctx (make-ctx targ #f))
(r1 (vector-ref (nat-target-gvm-reg-map targ) 1))
(translated-loc (nat-opnd cgc ctx loc))
(opnd1 (nat-opnd cgc ctx (list-ref opnds 0)))
(opnd2 (nat-opnd cgc ctx (list-ref opnds 1))))
(if (x86-reg? translated-loc)
(cond ((eq? translated-loc opnd1) (x86-add cgc translated-loc opnd2))
((eq? translated-loc opnd2) (x86-add cgc translated-loc opnd1))
(else
(x86-mov cgc translated-loc opnd1)
(x86-add cgc translated-loc opnd2)))
(cond ((x86-reg? opnd1)
(x86-push cgc opnd1)
(x86-add cgc opnd1 opnd2)
(x86-mov cgc translated-loc opnd1)
(x86-pop cgc opnd1))
((x86-reg? opnd2)
(x86-push cgc opnd2)
(x86-add cgc opnd2 opnd1)
(x86-mov cgc translated-loc opnd2)
(x86-pop cgc opnd2))
(else
(x86-push cgc r1)
(x86-mov cgc r1 opnd1)
(x86-add cgc r1 opnd2)
(x86-mov cgc translated-loc r1)
(x86-pop cgc r1)))))))

;; TODO: handle 0-ary, 1-ary and >2-ary cases
(x86-prim-define "##fx-" #f #f
(lambda (cgc opnds loc)
(let* ((targ (codegen-context-target cgc))
(ctx (make-ctx targ #f))
(r1 (vector-ref (nat-target-gvm-reg-map targ) 1))
(translated-loc (nat-opnd cgc ctx loc))
(opnd1 (nat-opnd cgc ctx (list-ref opnds 0)))
(opnd2 (nat-opnd cgc ctx (list-ref opnds 1))))
(if (x86-reg? translated-loc)
(cond ((eq? translated-loc opnd1) (x86-sub cgc translated-loc opnd2))
((eq? translated-loc opnd2)
(x86-neg cgc opnd2)
(x86-add cgc translated-loc opnd1)
(x86-neg cgc opnd2))
(else
(x86-mov cgc translated-loc opnd1)
(x86-sub cgc translated-loc opnd2)))
(cond ((x86-reg? opnd1)
(x86-push cgc opnd1)
(x86-sub cgc opnd1 opnd2)
(x86-mov cgc translated-loc opnd1)
(x86-pop cgc opnd1))
((x86-reg? opnd2)
(x86-push cgc opnd2)
(x86-sub cgc opnd2 opnd1)
(x86-mov cgc translated-loc opnd2)
(x86-pop cgc opnd2))
(else
(x86-push cgc r1)
(x86-mov cgc r1 opnd1)
(x86-sub cgc r1 opnd2)
(x86-mov cgc translated-loc r1)
(x86-pop cgc r1)))))))


;; FIXME: what to do with immediate values?
(define (box/unbox-fixnum cgc opnd fn)
(cond
((x86-reg? opnd)
(fn cgc opnd (x86-imm-int 2)))

(else
(let* ((targ (codegen-context-target cgc))
(r1 (vector-ref (nat-target-gvm-reg-map targ) 1)))
(x86-push cgc r1)
(x86-mov cgc r1 opnd)
(fn cgc r1 (x86-imm-int 2))
(x86-mov cgc opnd r1)
(x86-pop cgc r1)))))

(define (unbox-fixnum cgc opnd)
(box/unbox-fixnum cgc opnd x86-sar))

(define (box-fixnum cgc opnd)
(box/unbox-fixnum cgc opnd x86-shl))



(x86-prim-define "##fx<" #f #f
(lambda (cgc opnds loc)
(x86-nop cgc))

(lambda (cgc ctx opnds true-branch false-branch)
(let* ((targ (codegen-context-target cgc))
(true-lbl (nat-label-ref cgc (lbl->id true-branch (ctx-ns ctx))))
(false-lbl (nat-label-ref cgc (lbl->id false-branch (ctx-ns ctx))))
(r1 (vector-ref (nat-target-gvm-reg-map targ) 1))
(opnd1 (nat-opnd cgc ctx (list-ref opnds 0)))
(opnd2 (nat-opnd cgc ctx (list-ref opnds 1))))
(if (or (x86-reg? opnd1) (x86-reg? opnd2))
(x86-cmp cgc opnd1 opnd2)
(begin
(x86-push cgc r1)
(x86-mov cgc r1 opnd1)
(x86-cmp cgc r1 opnd2)
(x86-pop cgc r1)))
(x86-jl cgc true-lbl)
(x86-jmp cgc false-lbl))))

0 comments on commit 928e4f6

Please sign in to comment.