Skip to content

Commit

Permalink
first commit
Browse files Browse the repository at this point in the history
  • Loading branch information
@karttu
karttu committed Aug 28, 2011
1 parent 8119eec commit 617bf4d
Show file tree
Hide file tree
Showing 14 changed files with 10,902 additions and 0 deletions.
95 changes: 95 additions & 0 deletions src/combfscm.scm
View file
@@ -0,0 +1,95 @@

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; BREAM / combfscm.scm (combinational bream functions implemented ;;
;; in Scheme, for the needs of expwirms.scm) ;;
;; I.e. these are definitions for the functions that are executed ;;
;; at the compile time. (Usually in wirm-macros.) ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;
;; Unless otherwise mentioned, all the files in this code tree are
;; Copyright (C) 2010-2011 Antti Karttunen, subject to the terms of the GPL v2.
;; See the file COPYING for more information. Contact the author for
;; further developments at the address: <his-firstname>.<his-surname>@gmail.com
;;

;;
;; Antti Karttunen ("karttu") started writing this module Jul 27 2011.
;;

;;
;; Edited Aug 24 2011 by karttu.
;; Replaced the definition of bitnot (redand and rednand also use it)
;; with a temporary error message, until we take the width of
;; expressions properly into account. (Not a hard thing to do, actually.)
;;



(define (lognot b) (not b))

(define (logand . args)
(let loop ((args args))
(cond ((null? args) #t)
((not (car args)) #f)
(else (loop (cdr args)))
)
)
)


(define (logor . args)
(let loop ((args args))
(cond ((null? args) #f)
((not (not (car args))) #t)
(else (loop (cdr args)))
)
)
)


(define (bool->int b) (if b 1 0))

(define reduce-left reduce)

(define (bitand . args) (reduce-left int-and 0 args))
(define (bitor . args) (reduce-left int-or 0 args))
(define (bitxor . args) (reduce-left int-xor 0 args))
(define (bitnot arg1) (error "bitnot not yet implemented for compile-time reduction, because it needs also width of its arg to be known!")) ;; (int-not arg1)
(define (bitxnor . args) (reduce-left int-xnor 0 args))

;; These two are probably not well-defined in integer-literal context
;; in wirm-expansion:
(define (redand b) (bool->int (zero? (bitnot b))))
(define (rednand b) (bool->int (nonzero? (bitnot b)))) ;; XXX -- Is it this?!

(define (redor b) (bool->int (nonzero? b)))
(define (rednor b) (bool->int (zero? b)))

(define (redxor n) ;; reduced xor, i.e. the parity bit, the Thue-Morse seq.
(let loop ((n n) (i 0))
(if (zero? n) i (loop (>> n 1) (bitxor i (bitand n 1))))
)
)

(define (redxnor n) (bitnot (redxor n)))


(define (nonzero? i) (not (zero? i)))

(define (pow2? x) (logand (redor x) (rednor (bitand x (-1+ x)))))


(define (<< n i) (if (<= i 0) (>> n (- i)) (<< (+ n n) (- i 1))))
(define (>> n i) (if (zero? i) n (>> (floor->exact (/ n 2)) (- i 1))))

(define <<< <<) ;; XXX -- Check these later! (The signs for arithmetic shifts!)
(define >>> >>) ;; XXX -- Check these later! (The signs for arithmetic shifts!)

(define (bit n i) (bitand 1 (>> n i))) ;; XXX -- Check these later!
(define (bits n hl ll) (bitand (-1+ (<< 1 (1+ (- hl ll)))) (>> n ll))) ;; XXX!

(define (drop n i) (>> n i))

194 changes: 194 additions & 0 deletions src/combopti.scm
View file
@@ -0,0 +1,194 @@

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; BREAM / combopti.scm ;;
;; -- Optimizing-forms for the Level0 Combinational Logic. ;;
;; Used by compile module to simplify some of the ;;
;; Level0 expressions it generates. ;;
;; ;;
;; The entry point is (optimize-combinational-level0-code src coc) ;;
;; which will optimize the src-expression, if it can, and otherwise ;;
;; return it back as it was. ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;
;; Unless otherwise mentioned, all the files in this code tree are
;; Copyright (C) 2010-2011 Antti Karttunen, subject to the terms of the GPL v2.
;; See the file COPYING for more information. Contact the author for
;; further developments at the address: <his-firstname>.<his-surname>@gmail.com
;;

;;
;; Antti Karttunen ("karttu") started this module Sep 18 2010,
;; by transferring optimize-ternary-if and optimize-combinational-level0-code
;; from module compile1.scm and the dispatching code and macro definitions
;; from expsynta.scm

;;
;; Edited Sep 19 2010 by karttu.
;; Added reductions:
;; (bitand ... 0 ...) -> 0
;; (bitor ... non-zero-int ...) -> 1
;;
;; Edited Oct 10 2010 by karttu.
;; Realized that the latter reduction is wrong for bitor. Didn't fix it yet.
;;
;; Edited Oct 28 2010 by karttu.
;; Added one more kludgous argument for generic-dispatch.
;;
;; Edited Nov 04 2010 by karttu.
;; All cc stuff renamed coc (= compiling context, not current continuation!)
;;
;; Edited May 25 2011 by karttu.
;; Added the current year to the copyright notice.
;;
;; Edited Aug 25 2011 by karttu.
;; Edited bitand so that (bitand) (without args) gives back 1.
;; (Needed when invoking functions with no arguments).
;;

;;
;; XXX - Todo: Any more optimizations needed?
;; E.g. we could have
;; ((0 == and2_left_17) ? and2_left_17 : (i_3 > 1));
;; --> ((0 == and2_left_17) ? 0 : (i_3 > 1));
;;
;; In general:
;; (?: (== X <lit>) X Z) --> (?: (== X <lit>) <lit> Z)
;; (?: (== <lit> X) X Z) --> (?: (== X <lit>) <lit> Z)
;;
;; (?: (!= <lit> X) Z X) --> (?: (!= <lit> X) Z <lit>)
;; (?: (!= X <lit>) Z X) --> (?: (!= X <lit>) Z <lit>)
;;


(define *optimized-lev0-forms* (list (list '(regular 0.1 draft) (list (list (list))))))



(define (coc-list-of-optimized-lev0-forms-in-use coc)
(list-of-forms-by-dic (coc-calling-convention-in-use coc)
(coc-optimized-lev0-forms coc)
)
)


;; Called as:
;; (optimize-combinational-level0-code src coc)

(define (optimize-combinational-level0-code src coc)
(generic-dispatch src

src

(list-of-forms-by-dic
(coc-calling-convention-in-use coc)
*optimized-lev0-forms*
)

first

(lambda (x) x)

(lambda (x coc) x)

(lambda (x coc) x)

coc
)
)




(define-syntax define-optimized-lev0-form
(syntax-rules ()
((define-optimized-lev0-form (CACO formname src coc) body)
(attach!
(cons (quote formname) (lambda (src coc) body))
(list-of-forms-by-dic (quote CACO) *optimized-lev0-forms*)
)
)
)
)


(define-optimized-lev0-form ((regular 0.1 draft) ?: s coc)
(cond ((not (= 4 (length s)))
(error
"?: (lev0-optimizer): Form must have exactly three subexpressions: " s
)
)

(else
(let ((test-expr (optimize-combinational-level0-code (second s) coc))
(then-expr (optimize-combinational-level0-code (third s) coc))
(else-expr (optimize-combinational-level0-code (fourth s) coc))
)
(cond ((equal? 1 test-expr) then-expr) ;; Then it's always then.
((equal? 0 test-expr) else-expr)
;; Doesn't matter which one:
((equal? then-expr else-expr) then-expr)
(else `(,(car s) ,test-expr ,then-expr ,else-expr))
)
)
)
)
)



(define-optimized-lev0-form ((regular 0.1 draft) bitand s coc)
(cond ((null? (cdr s)) 1) ;; (bitand) without args is always true.
;; (error
;; "bitand (lev0-optimizer): Form must have at least one argument: " s
;; )

(else
(let* ((subexprs
(map (lambda (x) (optimize-combinational-level0-code x coc))
(cdr s)
)
)
(wod (delete 1 subexprs)) ;; wod = with-ones-deleted
)
(cond ((memq 0 wod) 0) ;; If any zero present, forces to zero.
((null? wod) 1) ;; (bitand) -> 1
((null? (cdr wod)) (first wod)) ;; (bitand any) --> any
(else (cons (first s) wod))
)
)
)
)
)


(define-optimized-lev0-form ((regular 0.1 draft) bitor s coc)
(cond ((null? (cdr s))
(error
"bitor (lev0-optimizer): Form must have at least one argument: " s
)
)

(else
(let* ((subexprs
(map (lambda (x) (optimize-combinational-level0-code x coc))
(cdr s)
)
)
(wzd (delete 0 subexprs)) ;; wzd = with-zeros-deleted
)
(cond ((there-exists? wzd ;; XXX -- True for logor, not bitor?!
(lambda (x) (and (integer? x) (not (zero? x))))
) 1) ;; if any non-zero integer present, forces true.
((null? wzd) 0) ;; (bitor) -> 0
((null? (cdr wzd)) (first wzd)) ;; (bitor any) --> any
(else (cons (first s) wzd))
)
)
)
)
)


0 comments on commit 617bf4d

Please sign in to comment.