Skip to content
Browse files

Added handling of 0 and 1 args for ##fx+ and ##fx*. Added ##fx+?

  • Loading branch information...
1 parent 1d9f2b2 commit 07e2456197f2bc639ef53b574b5e1a82c529fe17 @gnuvince gnuvince committed
Showing with 96 additions and 43 deletions.
  1. +96 −43 gsc/_t-x86.scm
View
139 gsc/_t-x86.scm
@@ -1186,12 +1186,58 @@
(x86-jmp cgc true-lbl))))
-;; TODO: handle 0-ary, 1-ary and >2-ary cases
+(define (mov cgc loc value)
+ (if (or (x86-reg? value) (x86-mov cgc loc value))
+ (x86-mov cgc loc value)
+ (let ((targ (codegen-context-target cgc))
+ (r1 (vector-ref (nat-target-gvm-reg-map targ) 1)))
+ (x86-push cgc r1)
+ (x86-mov cgc r1 value)
+ (x86-mov cgc loc r1)
+ (x86-pop cgc r1))))
+
+
+;; TODO: handle >2-ary cases
(x86-prim-define "##fx+" #f #f
(lambda (cgc opnds loc)
+ (cond ((null? opnds) (mov cgc loc (x86-imm-int 0)))
+ ((null? (cdr opnds)) (mov cgc loc (car opnds)))
+ (else
+ (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)))))))))
+
+(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))
+ (no-overflow (make-temp-label cgc))
(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))))
@@ -1216,51 +1262,57 @@
(x86-mov cgc r1 opnd1)
(x86-add cgc r1 opnd2)
(x86-mov cgc translated-loc r1)
- (x86-pop cgc r1)))))))
+ (x86-pop cgc r1))))
+ (x86-jno cgc no-overflow)
+ (mov cgc translated-loc false)
+ (x86-label cgc no-overflow))))
-;; TODO: handle 0-ary, 1-ary and >2-ary cases
+;; TODO: handle >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)
- (unbox-fixnum cgc opnd1)
- (x86-imul cgc translated-loc opnd2))
- ((eq? translated-loc opnd2)
- (unbox-fixnum cgc opnd2)
- (x86-imul cgc translated-loc opnd1))
- (else
- (x86-mov cgc translated-loc opnd1)
- (unbox-fixnum cgc translated-loc)
- (x86-imul cgc translated-loc opnd2)))
- (cond ((x86-reg? opnd1)
- (x86-push cgc opnd1)
- (unbox-fixnum cgc opnd1)
- (x86-imul cgc opnd1 opnd2)
- (x86-mov cgc translated-loc opnd1)
- (x86-pop cgc opnd1))
- ((x86-reg? opnd2)
- (x86-push cgc opnd2)
- (unbox-fixnum cgc opnd2)
- (x86-imul cgc opnd2 opnd1)
- (x86-mov cgc translated-loc opnd2)
- (x86-pop cgc opnd2))
- (else
- (x86-push cgc r1)
- (x86-mov cgc r1 opnd1)
- (unbox-fixnum cgc r1)
- (x86-imul cgc r1 opnd2)
- (x86-mov cgc translated-loc r1)
- (x86-pop cgc r1)))))))
-
-
-;; TODO: handle 0-ary, 1-ary and >2-ary cases
+ (cond ((null? opnds) (mov cgc loc (x86-imm-int 1)))
+ ((null? (cdr opnds)) (mov cgc loc (car opnds)))
+ (else
+ (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)
+ (unbox-fixnum cgc opnd1)
+ (x86-imul cgc translated-loc opnd2))
+ ((eq? translated-loc opnd2)
+ (unbox-fixnum cgc opnd2)
+ (x86-imul cgc translated-loc opnd1))
+ (else
+ (x86-mov cgc translated-loc opnd1)
+ (unbox-fixnum cgc translated-loc)
+ (x86-imul cgc translated-loc opnd2)))
+ (cond ((x86-reg? opnd1)
+ (x86-push cgc opnd1)
+ (unbox-fixnum cgc opnd1)
+ (x86-imul cgc opnd1 opnd2)
+ (x86-mov cgc translated-loc opnd1)
+ (x86-pop cgc opnd1))
+ ((x86-reg? opnd2)
+ (x86-push cgc opnd2)
+ (unbox-fixnum cgc opnd2)
+ (x86-imul cgc opnd2 opnd1)
+ (x86-mov cgc translated-loc opnd2)
+ (x86-pop cgc opnd2))
+ (else
+ (x86-push cgc r1)
+ (x86-mov cgc r1 opnd1)
+ (unbox-fixnum cgc r1)
+ (x86-imul cgc r1 opnd2)
+ (x86-mov cgc translated-loc r1)
+ (x86-pop cgc r1)))))))))
+
+
+;; TODO: handle 1-ary and >2-ary cases
(x86-prim-define "##fx-" #f #f
(lambda (cgc opnds loc)
(let* ((targ (codegen-context-target cgc))
@@ -1320,7 +1372,8 @@
-
+;; All fixnum primitives (<, <=, =, >=, >) are defined simply in terms
+;; of their names and their corresponding jump operation.
(define (define-fxcmp-primitive name jump-op)
(x86-prim-define name #f #f
(lambda (cgc opnds loc)

0 comments on commit 07e2456

Please sign in to comment.
Something went wrong with that request. Please try again.