Skip to content

Commit

Permalink
Added better test for copy translation to avoid lots of stack pushing…
Browse files Browse the repository at this point in the history 
…/popping
  • Loading branch information
@gnuvince
gnuvince committed Jul 13, 2012
1 parent 921b06d commit 415dc5f
Showing 1 changed file with 74 additions and 48 deletions.
122 changes: 74 additions & 48 deletions gsc/_t-x86.scm
View file
@@ -1,5 +1,11 @@
;;;============================================================================

;; TODO
;; - Clean up creation of global labels and their insertion into the global table.
;; - ##not primitive
;; - if.scm unit test.
;; - Fix nargs (%cl) + %ecx

;;; File: "_t-x86.scm"

;;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
Expand Down Expand Up @@ -375,25 +381,43 @@

;;;; ***** DUMPING OF A COMPILATION MODULE

;; Table from symbol to asm-labels.
(define nat-labels (make-table test: eq?))

;; 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 #f)
(define nat-label-set! #f)
(define nat-label-list #f)
(let ((labels (make-table test: eq?)))
(set! nat-label-list (lambda () (table->list labels)))
(set! nat-label-ref
(lambda (cgc label-name)
(let ((x (table-ref labels label-name #f)))
(if x
x
(let ((l (asm-make-label cgc label-name)))
(table-set! labels label-name l)
l)))))
(set! nat-label-set!
(lambda (cgc label-name val)
(table-set! labels label-name val))))
(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))))
(define (nat-label-set! cgc label-name val)
(table-set! nat-labels label-name val))


;; Table from symbol to pstate offset.
(define nat-globals (make-table test: eq?))

;; Get the memory address of a symbol. If the symbol doesn't exist,
;; add it to the table.
(define nat-global-ref
(let ((current -1))
(lambda (targ symbol)
(let* ((x (table-ref nat-globals symbol #f))
(offset (if x
x
(begin
(set! current (+ current 1))
(table-set! nat-globals symbol current)
current))))
(x86-mem (* (nat-target-word-width targ)
(+ nat-globals-slot offset))
(nat-target-pstate-ptr-reg targ))))))




;; Queue containing the procs we've seen so far. (Could we use a set instead?)
Expand Down Expand Up @@ -440,12 +464,11 @@
(println-lbl (nat-label-ref cgc 'println)))
(codegen-context-target-set! cgc targ)
(x86-jmp cgc main-lbl)
(generate-primitives cgc)
(generate-println cgc println-lbl)
(x86-translate-procs cgc)
(entry-point cgc (list-ref procs 0))

(pp (nat-label-list))
(pp (table->list nat-globals))
(let ((f (create-procedure cgc #t)))
(f)))
#f)
Expand All @@ -465,25 +488,6 @@
(define nat-heap-size (expt 2 20))
(define nat-heap-fudge (expt 2 14))

;; Table from symbol to pstate offset.
(define nat-globals (make-table test: eq?))

;; Get the memory address of a symbol. If the symbol doesn't exist,
;; add it to the table.
(define nat-global-ref
(let ((current -1))
(lambda (targ symbol)
(let* ((x (table-ref nat-globals symbol #f))
(offset (if x
x
(begin
(set! current (+ current 1))
(table-set! nat-globals symbol current)
current))))
(x86-mem (* (nat-target-word-width targ)
(+ nat-globals-slot offset))
(nat-target-pstate-ptr-reg targ))))))



(define (entry-point cgc main-proc)
Expand Down Expand Up @@ -543,6 +547,8 @@
(x86-mov cgc (vector-ref (nat-target-gvm-reg-map targ) 3) (x86-imm-int 0))
(x86-mov cgc (vector-ref (nat-target-gvm-reg-map targ) 4) (x86-imm-int 0))

(pp (table->list nat-globals))
(pp (table->list nat-labels))
(let ((mem-loc (nat-global-ref targ 'println))
(mem-opnd (nat-label-ref cgc 'println)))
(x86-push cgc (vector-ref (nat-target-gvm-reg-map targ) 1))
Expand Down Expand Up @@ -631,16 +637,19 @@
(scan-opnd loc)
(let ((loc* (nat-opnd cgc ctx loc))
(opnd* (nat-opnd cgc ctx opnd)))
(if (not (or (x86-reg? loc*) (x86-reg? opnd*)))
(if (or (x86-reg? loc*)
(x86-reg? opnd*)
(x86-imm-int? loc*)
(x86-imm-int? opnd*))
(x86-mov cgc
(if (asm-label? loc*) (x86-imm-lbl loc*) loc*)
(if (asm-label? opnd*) (x86-imm-lbl opnd*) opnd*)
(* (nat-target-word-width targ) 8))
(let ((temp-reg (vector-ref (nat-target-gvm-reg-map targ) 1)))
(x86-push cgc temp-reg)
(x86-mov cgc temp-reg (if (asm-label? opnd*) (x86-imm-lbl opnd*) opnd*))
(x86-mov cgc (if (asm-label? loc*) (x86-imm-lbl loc*) loc*) temp-reg)
(x86-pop cgc temp-reg))
(x86-mov cgc
(if (asm-label? loc*) (x86-imm-lbl loc*) loc*)
(if (asm-label? opnd*) (x86-imm-lbl opnd*) opnd*)
(* (nat-target-word-width targ) 8))))))
(x86-pop cgc temp-reg))))))

((close)
(nat-close cgc (close-parms gvm-instr)))
Expand Down Expand Up @@ -728,18 +737,15 @@
((lbl? opnd)
(let* ((lbl-name (translate-lbl ctx opnd))
(asm-lbl (nat-label-ref cgc lbl-name)))
;; (asm-lbl (asm-make-label cgc lbl-name)))
;; (nat-label-set! cgc lbl-name asm-lbl)
asm-lbl))
;; (let ((n (lbl-num opnd)))
;; (let ((lbl (nat-label-lookup targ n 'current-code-variant)))
;; (x86-imm-lbl lbl 0))))

((obj? opnd)
(let ((val (obj-val opnd)))
(cond ((and (integer? val) (exact? val))
(x86-imm-int (* val 4)))
((proc-obj? val)
;; Is there entry-point of a procedure always going to be
;; at label 1?
(let ((lbl-name (lbl->id 1 (proc-obj-name val))))
(nat-label-ref cgc lbl-name)))
((eq? val #f)
Expand Down Expand Up @@ -793,6 +799,11 @@



(define true (x86-imm-int -6))
(define false (x86-imm-int -2))



(define (generate-println cgc println-lbl)
(let* ((targ (codegen-context-target cgc))
(print-lbl (asm-make-label cgc 'print))
Expand Down Expand Up @@ -1011,4 +1022,19 @@
))


(define (generate-primitives cgc)
(let ((targ (codegen-context-target cgc)))
;; ##not
(let ((eq-label (asm-make-label cgc '##not-eq)))
(x86-label cgc (nat-label-ref targ '##not))
(x86-cmp cgc (vector-ref (nat-target-gvm-reg-map targ) 1) false)
(x86-je cgc eq-label)
(x86-mov cgc (vector-ref (nat-target-gvm-reg-map targ) 1) true)
(x86-jmp cgc (vector-ref (nat-target-gvm-reg-map targ) 0))
(x86-label cgc eq-label)
(x86-mov cgc (vector-ref (nat-target-gvm-reg-map targ) 1) false)
(x86-jmp cgc (vector-ref (nat-target-gvm-reg-map targ) 0)))))



;;;============================================================================

0 comments on commit 415dc5f

Please sign in to comment.