conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
ikarus/scheme/ikarus.compiler.altcogen.ss

2935 lines
100 KiB
Scheme
Raw Normal View History

* Added license stubs to all *.ss and *.[ch] files.
2007-10-25 16:27:34 -04:00
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
Added -m32 to CFLAGS/LDFLAGS, updated copyright dates and version no.
2008-01-29 00:34:34 -05:00
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
* Added license stubs to all *.ss and *.[ch] files.
2007-10-25 16:27:34 -04:00
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
(module (alt-cogen compile-call-frame)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;; input to cogen is <Program>:
;;; <Expr> ::= (constant x)
;;; | (var)
;;; | (primref name)
;;; | (bind var* <Expr>* <Expr>)
;;; | (fix var* <FixRhs>* <Expr>)
;;; | (conditional <Expr> <Expr> <Expr>)
;;; | (seq <Expr> <Expr>)
;;; | (closure <codeloc> <var>*) ; thunk special case
;;; | (forcall "name" <Expr>*)
;;; | (funcall <Expr> <Expr>*)
;;; | (jmpcall <label> <Expr> <Expr>*)
;;; | (mvcall <Expr> <clambda>)
;;; <codeloc> ::= (code-loc <label>)
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
;;; <clambda> ::= (clambda <label> <case>* <cp> <free var>*)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;; <case> ::= (clambda-case <info> <body>)
;;; <info> ::= (clambda-info label <arg var>* proper)
;;; <Program> ::= (codes <clambda>* <Expr>)
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
* removed more junk.
2007-06-05 20:11:12 -04:00
(define (introduce-primcalls x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* removed more junk.
2007-06-05 20:11:12 -04:00
(define who 'introduce-primcalls)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (check-gensym x)
(unless (gensym? x)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "invalid gensym" x)))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (check-label x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(code-loc label)
(check-gensym label)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid label" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (check-var x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(var) (void)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid var" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (check-closure x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(closure label free*)
(check-label label)
(for-each check-var free*)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid closure" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (mkfuncall op arg*)
cleanup of repository content.
2007-03-09 19:28:38 -05:00
(import primops)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case op
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(primref name)
(cond
* completed the move to new specify-representation pass infrastructure.
2007-03-03 23:17:04 -05:00
[(primop? name)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(make-primcall name arg*)]
[else (make-funcall op arg*)])]
[else (make-funcall op arg*)]))
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Expr x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(constant) x]
[(var) x]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(fix lhs* rhs* body)
(make-fix lhs* rhs* (Expr body))]
[(conditional e0 e1 e2)
(make-conditional (Expr e0) (Expr e1) (Expr e2))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
[(closure) x]
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator arg*)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(mkfuncall (Expr rator) (map Expr arg*))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(jmpcall label rator arg*)
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid expr" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (ClambdaCase x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(clambda-case info body)
(make-clambda-case info (Expr body))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid clambda-case" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Clambda x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
[(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) cp free* name)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid clambda" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Program x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(codes code* body)
(make-codes (map Clambda code*) (Expr body))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid program" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(Program x))
(define (eliminate-fix x)
;;;
(define who 'eliminate-fix)
;;;
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
(define (Expr main-cpvar cpvar free*)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Var x)
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
(cond
[(eq? x main-cpvar) cpvar]
[else
(let f ([free* free*] [i 0])
(cond
[(null? free*) x]
[(eq? x (car free*))
(make-primcall '$cpref (list cpvar (make-constant i)))]
[else (f (cdr free*) (fxadd1 i))]))]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (do-fix lhs* rhs* body)
* fixed an assembler bug in "addl reg -> mem"
2007-02-13 17:24:00 -05:00
(define (handle-closure x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Loops with a single free variable no longer allocate a closure.
2008-02-11 22:18:32 -05:00
[(closure code free* well-known?)
(make-closure code (map Var free*) well-known?)]))
* fixed an assembler bug in "addl reg -> mem"
2007-02-13 17:24:00 -05:00
(make-fix lhs* (map handle-closure rhs*) body))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Expr x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(constant) x]
[(var) (Var x)]
[(primref) x]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(fix lhs* rhs* body)
(do-fix lhs* rhs* (Expr body))]
[(conditional e0 e1 e2)
(make-conditional (Expr e0) (Expr e1) (Expr e2))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
* fixed an assembler bug in "addl reg -> mem"
2007-02-13 17:24:00 -05:00
[(closure)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(let ([t (unique-var 'tmp)])
(Expr (make-fix (list t) (list x) t)))]
[(primcall op arg*)
* passinf 2.2
2007-02-11 19:17:59 -05:00
(make-primcall op (map Expr arg*))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator arg*)
(make-funcall (Expr rator) (map Expr arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid expr" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
Expr)
;;;
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
(define (ClambdaCase main-cp free*)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(lambda (x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(clambda-case info body)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case info
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(case-info label args proper)
(let ([cp (unique-var 'cp)])
(make-clambda-case
(make-case-info label (cons cp args) proper)
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
((Expr main-cp cp free*) body)))])]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid clambda-case" x)])))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Clambda x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
[(clambda label case* cp free* name)
(make-clambda label (map (ClambdaCase cp free*) case*)
some compiler cleanup
2008-02-11 09:29:59 -05:00
#f free* name)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid clambda" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Program x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(codes code* body)
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
(make-codes (map Clambda code*) ((Expr #f #f '()) body))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid program" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(Program x))
* fixed bug in the graph construction that caused the operand of idivl not to be added to the live set.
2007-03-02 00:41:28 -05:00
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
(define-syntax seq*
(syntax-rules ()
[(_ e) e]
[(_ e* ... e)
(make-seq (seq* e* ...) e)]))
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
(define (insert-engine-checks x)
* Two minor non-optimizations for $event-check and $stack-overflow-check * If a procedure does not make non-tail calls, stack-overflow is eliminated. * If a procedure does not make any calls (leaf routine), then event-check is eliminated as well. (total savings: about 10% reduction in boot-file size)
2007-11-05 16:23:13 -05:00
(define who 'insert-engine-checks)
(define (Expr x)
(struct-case x
[(constant) #f]
[(var) #f]
[(primref) #f]
[(jmpcall label rator arg*) #t]
[(mvcall rator k) #t]
[(funcall rator arg*)
(if (primref? rator) (ormap Expr arg*) #t)]
[(bind lhs* rhs* body) (or (ormap Expr rhs*) (Expr body))]
[(fix lhs* rhs* body) (Expr body)]
[(conditional e0 e1 e2) (or (Expr e0) (Expr e1) (Expr e2))]
[(seq e0 e1) (or (Expr e0) (Expr e1))]
[(primcall op arg*) (ormap Expr arg*)]
[(forcall op arg*) (ormap Expr arg*)]
[else (error who "invalid expr" x)]))
(define (Main x)
(if (Expr x)
(make-seq (make-primcall '$do-event '()) x)
x))
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
(define (CaseExpr x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
[(clambda-case info body)
* Two minor non-optimizations for $event-check and $stack-overflow-check * If a procedure does not make non-tail calls, stack-overflow is eliminated. * If a procedure does not make any calls (leaf routine), then event-check is eliminated as well. (total savings: about 10% reduction in boot-file size)
2007-11-05 16:23:13 -05:00
(make-clambda-case info (Main body))]))
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
(define (CodeExpr x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
[(clambda L cases cp free name)
(make-clambda L (map CaseExpr cases) cp free name)]))
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
(define (CodesExpr x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
[(codes list body)
* Two minor non-optimizations for $event-check and $stack-overflow-check * If a procedure does not make non-tail calls, stack-overflow is eliminated. * If a procedure does not make any calls (leaf routine), then event-check is eliminated as well. (total savings: about 10% reduction in boot-file size)
2007-11-05 16:23:13 -05:00
(make-codes (map CodeExpr list) (Main body))]))
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
(CodesExpr x))
* Switched order of two compiler passes: specify-representation and insert-stack-overflow-check. This will make it easier to remove unnecessary stack checks and to add some that we *may* be missing. * Added a $stack-overflow-check primitive that takes care of checking and calling ikrt_stack_overflow if we did detect an overflow.
2007-11-05 15:30:42 -05:00
* Stack overflow is reinstated. fibc and other call/cc intensive benchmarks now work.
2007-07-13 06:54:25 -04:00
(define (insert-stack-overflow-check x)
(define who 'insert-stack-overflow-check)
* Two minor non-optimizations for $event-check and $stack-overflow-check * If a procedure does not make non-tail calls, stack-overflow is eliminated. * If a procedure does not make any calls (leaf routine), then event-check is eliminated as well. (total savings: about 10% reduction in boot-file size)
2007-11-05 16:23:13 -05:00
(define (NonTail x)
(struct-case x
[(constant) #f]
[(var) #f]
[(primref) #f]
[(funcall rator arg*) #t]
[(jmpcall label rator arg*) #t]
[(mvcall rator k) #t]
[(bind lhs* rhs* body) (or (ormap NonTail rhs*) (NonTail body))]
[(fix lhs* rhs* body) (NonTail body)]
[(conditional e0 e1 e2) (or (NonTail e0) (NonTail e1) (NonTail e2))]
[(seq e0 e1) (or (NonTail e0) (NonTail e1))]
[(primcall op arg*) (ormap NonTail arg*)]
[(forcall op arg*) (ormap NonTail arg*)]
[else (error who "invalid expr" x)]))
(define (Tail x)
(struct-case x
[(constant) #f]
[(var) #f]
[(primref) #f]
[(bind lhs* rhs* body) (or (ormap NonTail rhs*) (Tail body))]
[(fix lhs* rhs* body) (Tail body)]
[(conditional e0 e1 e2) (or (NonTail e0) (Tail e1) (Tail e2))]
[(seq e0 e1) (or (NonTail e0) (Tail e1))]
[(primcall op arg*) (ormap NonTail arg*)]
[(forcall op arg*) (ormap NonTail arg*)]
[(funcall rator arg*) (or (NonTail rator) (ormap NonTail arg*))]
[(jmpcall label rator arg*) (or (NonTail rator) (ormap NonTail arg*))]
[(mvcall rator k) #t] ; punt
[else (error who "invalid expr" x)]))
* Stack overflow is reinstated. fibc and other call/cc intensive benchmarks now work.
2007-07-13 06:54:25 -04:00
(define (insert-check x)
* Switched order of two compiler passes: specify-representation and insert-stack-overflow-check. This will make it easier to remove unnecessary stack checks and to add some that we *may* be missing. * Added a $stack-overflow-check primitive that takes care of checking and calling ikrt_stack_overflow if we did detect an overflow.
2007-11-05 15:30:42 -05:00
(make-seq (make-primcall '$stack-overflow-check '()) x))
* Stack overflow is reinstated. fibc and other call/cc intensive benchmarks now work.
2007-07-13 06:54:25 -04:00
* Switched order of two compiler passes: specify-representation and insert-stack-overflow-check. This will make it easier to remove unnecessary stack checks and to add some that we *may* be missing. * Added a $stack-overflow-check primitive that takes care of checking and calling ikrt_stack_overflow if we did detect an overflow.
2007-11-05 15:30:42 -05:00
(define (ClambdaCase x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* Stack overflow is reinstated. fibc and other call/cc intensive benchmarks now work.
2007-07-13 06:54:25 -04:00
[(clambda-case info body)
(make-clambda-case info (Main body))]))
;;;
(define (Clambda x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
[(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) cp free* name)]))
* Stack overflow is reinstated. fibc and other call/cc intensive benchmarks now work.
2007-07-13 06:54:25 -04:00
;;;
(define (Main x)
(if (Tail x)
(insert-check x)
x))
;;;
(define (Program x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* Stack overflow is reinstated. fibc and other call/cc intensive benchmarks now work.
2007-07-13 06:54:25 -04:00
[(codes code* body)
(make-codes (map Clambda code*) (Main body))]))
;;;
(Program x))
* Switched order of two compiler passes: specify-representation and insert-stack-overflow-check. This will make it easier to remove unnecessary stack checks and to add some that we *may* be missing. * Added a $stack-overflow-check primitive that takes care of checking and calling ikrt_stack_overflow if we did detect an overflow.
2007-11-05 15:30:42 -05:00
(include "pass-specify-rep.ss")
* Stack overflow is reinstated. fibc and other call/cc intensive benchmarks now work.
2007-07-13 06:54:25 -04:00
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define parameter-registers '(%edi))
(define return-value-register '%eax)
(define cp-register '%edi)
small bug fix in assembler for code like (movl reg (disp reg reg))
2007-12-31 03:02:12 -05:00
(define all-registers
'(%eax %edi %ebx %edx %ecx))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define argc-register '%eax)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
* removed the reg? argument to build-graph. Reg? was needed when build-graph was used for constructing both frame conflicts and register conflicts. Now, it's only used for register conflicts so reg? is no longer needed.
2007-06-05 23:10:28 -04:00
;;; apr = %ebp
;;; esp = %esp
;;; pcr = %esi
;;; cpr = %edi
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (register-index x)
(cond
[(assq x '([%eax 0] [%edi 1] [%ebx 2] [%edx 3]
[%ecx 4] [%esi 5] [%esp 6] [%ebp 7]))
=> cadr]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error 'register-index "not a register" x)]))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
small bug fix in assembler for code like (movl reg (disp reg reg))
2007-12-31 03:02:12 -05:00
(define non-8bit-registers
'(%edi))
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (impose-calling-convention/evaluation-order x)
(define who 'impose-calling-convention/evaluation-order)
;;;
;;;
(define (S* x* k)
(cond
[(null? x*) (k '())]
[else
(S (car x*)
(lambda (a)
(S* (cdr x*)
(lambda (d)
(k (cons a d))))))]))
;;;
(define (S x k)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* passinf 2.2
2007-02-11 19:17:59 -05:00
[(bind lhs* rhs* body)
(do-bind lhs* rhs* (S body k))]
[(seq e0 e1)
(make-seq (E e0) (S e1 k))]
[else
(cond
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
[(or (constant? x) (symbol? x)) (k x)]
[(var? x)
(cond
[(var-loc x) => k]
[else (k x)])]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(or (funcall? x) (primcall? x) (jmpcall? x)
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(forcall? x) (shortcut? x)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(conditional? x))
* passinf 2.2
2007-02-11 19:17:59 -05:00
(let ([t (unique-var 'tmp)])
(do-bind (list t) (list x)
(k t)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid S" x)])]))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;(define (Mem x k)
; (struct-case x
; [(primcall op arg*)
; (if (eq? op 'mref)
; (S* arg*
; (lambda (arg*)
; (make-disp (car arg*) (cadr arg*))))
; (S x k))]
; [else (S x k)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (do-bind lhs* rhs* body)
(cond
[(null? lhs*) body]
[else
(set! locals (cons (car lhs*) locals))
(make-seq
(V (car lhs*) (car rhs*))
(do-bind (cdr lhs*) (cdr rhs*) body))]))
;;;
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (nontail-locations args)
(let f ([regs parameter-registers] [args args])
(cond
[(null? args) (values '() '() '())]
[(null? regs) (values '() '() args)]
[else
(let-values ([(r* rl* f*) (f (cdr regs) (cdr args))])
(values (cons (car regs) r*)
(cons (car args) rl*)
f*))])))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (make-set lhs rhs)
(make-asm-instr 'move lhs rhs))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (do-bind-frmt* nf* v* ac)
(cond
[(null? nf*) ac]
[else
* looks not bad.
2007-02-19 23:33:29 -05:00
(make-seq
(V (car nf*) (car v*))
(do-bind-frmt* (cdr nf*) (cdr v*) ac))]))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
;;;
* passing 2.1
2007-02-11 18:52:10 -05:00
(define (handle-nontail-call rator rands value-dest call-targ)
* newcogen passes 1.6
2007-02-11 17:51:42 -05:00
(let-values ([(reg-locs reg-args frm-args)
(nontail-locations (cons rator rands))])
(let ([regt* (map (lambda (x) (unique-var 'rt)) reg-args)]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[frmt* (map (lambda (x) (make-nfv 'unset-conflicts #f #f #f #f))
frm-args)])
* passing 2.1
2007-02-11 18:52:10 -05:00
(let* ([call
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(make-ntcall call-targ value-dest
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* argc-register
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
pcr esp apr
(append reg-locs frmt*))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
#f #f)]
* passing 2.1
2007-02-11 18:52:10 -05:00
[body
(make-nframe frmt* #f
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(do-bind-frmt* frmt* frm-args
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(do-bind (cdr regt*) (cdr reg-args)
;;; evaluate cpt last
(do-bind (list (car regt*)) (list (car reg-args))
(assign* reg-locs regt*
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
call))))))])
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(if value-dest
* passing 2.1
2007-02-11 18:52:10 -05:00
(make-seq body (make-set value-dest return-value-register))
* newcogen passes 1.6
2007-02-11 17:51:42 -05:00
body)))))
* keyboard interrupts are now continuable.
2007-11-15 13:40:36 -05:00
;;; (define (alloc-check size)
;;; (E (make-conditional ;;; PCB ALLOC-REDLINE
;;; (make-primcall '<=
;;; (list (make-primcall 'int+ (list apr size))
;;; (make-primcall 'mref (list pcr (make-constant 4)))))
;;; (make-primcall 'nop '())
;;; (make-funcall
;;; (make-primcall 'mref
;;; (list
;;; (make-constant (make-object (primref->symbol 'do-overflow)))
;;; (make-constant (- disp-symbol-record-proc symbol-ptag))))
;;; (list size)))))
* adding some asm tests in asm-tests.ss
2007-02-13 05:08:48 -05:00
(define (alloc-check size)
* keyboard interrupts are now continuable.
2007-11-15 13:40:36 -05:00
(E (make-shortcut
(make-conditional ;;; PCB ALLOC-REDLINE
(make-primcall '<=
(list (make-primcall 'int+ (list apr size))
removed some hard-coded constants of pcb-offsets.
2008-01-01 23:07:41 -05:00
(make-primcall 'mref
(list pcr
(make-constant pcb-allocation-redline)))))
* keyboard interrupts are now continuable.
2007-11-15 13:40:36 -05:00
(make-primcall 'nop '())
(make-primcall 'interrupt '()))
* adding some asm tests in asm-tests.ss
2007-02-13 05:08:48 -05:00
(make-funcall
(make-primcall 'mref
* Fixed bug 160483: described as "incorrect number of arguments" reported as "not a function" - The real reason was in the register allocator, where one live variable (the memmory size of the bytevector) was not marked live across the call to do-overflow. When the overflow returned, the value of that variable (which was in the %ebx register) was trashed, leading to an incorrect bump in the allocation pointer. - Note to self, never blame anything on cache coherency again!
2007-11-06 17:04:27 -05:00
(list
(make-constant (make-object (primref->symbol 'do-overflow)))
(make-constant (- disp-symbol-record-proc symbol-ptag))))
* adding some asm tests in asm-tests.ss
2007-02-13 05:08:48 -05:00
(list size)))))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;; impose value
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (V d x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(constant) (make-set d x)]
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
[(var)
(cond
[(var-loc x) => (lambda (loc) (make-set d loc))]
[else (make-set d x)])]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(bind lhs* rhs* e)
(do-bind lhs* rhs* (V d e))]
[(seq e0 e1)
(make-seq (E e0) (V d e1))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (V d e1) (V d e2))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(primcall op rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(case op
[(alloc)
(S (car rands)
(lambda (size)
* adding some asm tests in asm-tests.ss
2007-02-13 05:08:48 -05:00
(make-seq
(alloc-check size)
(S (cadr rands)
(lambda (tag)
(make-seq
(make-seq
(make-set d apr)
(make-asm-instr 'logor d tag))
(make-asm-instr 'int+ apr size)))))))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(mref)
(S* rands
(lambda (rands)
(make-set d (make-disp (car rands) (cadr rands)))))]
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(mref32)
(S* rands
(lambda (rands)
(make-asm-instr 'load32 d
(make-disp (car rands) (cadr rands)))))]
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
[(bref)
(S* rands
(lambda (rands)
(make-asm-instr 'move-byte d
(make-disp (car rands) (cadr rands)))))]
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
[(logand logxor logor int+ int- int*
* optimized symbol calls using the symbol-function field. * added error checks for applying nonprocedures.
2007-02-25 21:29:28 -05:00
int-/overflow int+/overflow int*/overflow)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(make-seq
(V d (car rands))
(S (cadr rands)
(lambda (s)
(make-asm-instr op d s))))]
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[(remainder)
(S* rands
(lambda (rands)
(seq*
(make-set eax (car rands))
(make-asm-instr 'cltd edx eax)
(make-asm-instr 'idiv eax (cadr rands))
(make-set d eax))))]
[(quotient)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
(S* rands
(lambda (rands)
(seq*
(make-set eax (car rands))
(make-asm-instr 'cltd edx eax)
(make-asm-instr 'idiv edx (cadr rands))
(make-set d edx))))]
fxarithmetic-shift-left now detects overflows properly.
2008-03-18 00:49:24 -04:00
[(sll sra srl sll/overflow)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(let ([a (car rands)] [b (cadr rands)])
(cond
[(constant? b)
(make-seq
(V d a)
(make-asm-instr op d b))]
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[else
(S b
(lambda (b)
(seq*
(V d a)
(make-set ecx b)
(make-asm-instr op d ecx))))]))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid value op" op)])]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(funcall rator rands)
* passing 2.1
2007-02-11 18:52:10 -05:00
(handle-nontail-call rator rands d #f)]
[(jmpcall label rator rands)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(handle-nontail-call rator rands d label)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(forcall op rands)
(handle-nontail-call
(make-constant (make-foreign-label op))
rands d op)]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
(make-shortcut
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
(V d body)
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
(V d handler))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[else
(if (symbol? x)
(make-set d x)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "invalid value" (unparse x)))]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (assign* lhs* rhs* ac)
(cond
[(null? lhs*) ac]
[else
(make-seq
(make-set (car lhs*) (car rhs*))
(assign* (cdr lhs*) (cdr rhs*) ac))]))
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (VT x)
* completed the move to new specify-representation pass infrastructure.
2007-03-03 23:17:04 -05:00
(S x
(lambda (x)
(make-seq
(make-set return-value-register x)
* Fixed bug 160483: described as "incorrect number of arguments" reported as "not a function" - The real reason was in the register allocator, where one live variable (the memmory size of the bytevector) was not marked live across the call to do-overflow. When the overflow returned, the value of that variable (which was in the %ebx register) was trashed, leading to an incorrect bump in the allocation pointer. - Note to self, never blame anything on cache coherency again!
2007-11-06 17:04:27 -05:00
(make-primcall 'return
(list pcr esp apr return-value-register))))))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;; impose effect
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (E x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(seq e0 e1) (make-seq (E e0) (E e1))]
[(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(bind lhs* rhs* e)
(do-bind lhs* rhs* (E e))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(primcall op rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(case op
Passing 709 tests in 64-bit mode
2008-04-12 15:06:55 -04:00
[(mset bset bset/c bset/h mset32)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(S* rands
(lambda (s*)
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
(make-asm-instr op
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(make-disp (car s*) (cadr s*))
(caddr s*))))]
* $fixnum->flonum now works.
2007-06-18 07:29:39 -04:00
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
fl:from-int fl:shuffle bswap!
fl:store-single fl:load-single)
* Added native support for $fl+, $fl-, $fl*, $fl/
2007-06-15 01:53:34 -04:00
(S* rands
(lambda (s*)
(make-asm-instr op (car s*) (cadr s*))))]
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(nop interrupt incr/zero? fl:double->single
fl:single->double) x]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error 'impose-effect "invalid instr" x)])]
* fixed an assembler bug in "addl reg -> mem"
2007-02-13 17:24:00 -05:00
[(funcall rator rands)
* passing 2.1
2007-02-11 18:52:10 -05:00
(handle-nontail-call rator rands #f #f)]
tests 2.4 pass
2007-02-11 21:18:12 -05:00
[(jmpcall label rator rands)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(handle-nontail-call rator rands #f label)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(forcall op rands)
(handle-nontail-call
(make-constant (make-foreign-label op))
rands #f op)]
* optimized symbol calls using the symbol-function field. * added error checks for applying nonprocedures.
2007-02-25 21:29:28 -05:00
[(shortcut body handler)
(make-shortcut (E body) (E handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" x)]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;; impose pred
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant) x]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(seq e0 e1) (make-seq (E e0) (P e1))]
[(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(bind lhs* rhs* e)
(do-bind lhs* rhs* (P e))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(primcall op rands)
* fixed an assembler bug in "addl reg -> mem"
2007-02-13 17:24:00 -05:00
(let ([a (car rands)] [b (cadr rands)])
(cond
[(and (constant? a) (constant? b))
(let ([t (unique-var 'tmp)])
(P (make-bind (list t) (list a)
(make-primcall op (list t b)))))]
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;[(constant? a)
; (Mem b (lambda (b) (make-asm-instr op a b)))]
;[(constant? b)
; (Mem a (lambda (a) (make-asm-instr op a b)))]
* fixed an assembler bug in "addl reg -> mem"
2007-02-13 17:24:00 -05:00
[else
(S* rands
(lambda (rands)
(let ([a (car rands)] [b (cadr rands)])
(make-asm-instr op a b))))]))]
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[(shortcut body handler)
(make-shortcut (P body) (P handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid pred" x)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
;;;
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
(define (handle-tail-call target rator rands)
(let* ([args (cons rator rands)]
[locs (formals-locations args)]
[rest
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
(cond
[target
(make-primcall 'direct-jump
(cons target
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* argc-register
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
pcr esp apr
locs)))]
[else
(make-primcall 'indirect-jump
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* argc-register
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
pcr esp apr
locs))]))])
(let f ([args (reverse args)]
[locs (reverse locs)]
[targs '()]
[tlocs '()])
(cond
[(null? args) (assign* tlocs targs rest)]
[(constant? (car args))
(f (cdr args) (cdr locs)
(cons (car args) targs)
(cons (car locs) tlocs))]
[(and (fvar? (car locs))
(var? (car args))
(eq? (car locs) (var-loc (car args))))
(f (cdr args) (cdr locs) targs tlocs)]
[else
(let ([t (unique-var 'tmp)])
(set! locals (cons t locals))
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(make-seq
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
(V t (car args))
(f (cdr args) (cdr locs)
(cons t targs) (cons (car locs) tlocs))))]))))
(define (Tail x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
[(constant) (VT x)]
[(var) (VT x)]
[(primcall op rands)
(case op
[($call-with-underflow-handler)
(let ([t0 (unique-var 't)]
[t1 (unique-var 't)]
[t2 (unique-var 't)]
[handler (car rands)]
[proc (cadr rands)]
[k (caddr rands)])
* Added cons*
2007-09-09 23:31:19 -04:00
(set! locals (cons* t0 t1 t2 locals))
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
(seq*
(V t0 handler)
(V t1 k)
(V t2 proc)
(make-set (mkfvar 1) t0)
(make-set (mkfvar 2) t1)
(make-set cpr t2)
(make-set argc-register (make-constant (argc-convention 1)))
(make-asm-instr 'int- fpr (make-constant wordsize))
(make-primcall 'indirect-jump
(list argc-register cpr pcr esp apr
(mkfvar 1) (mkfvar 2)))))]
[else (VT x)])]
[(bind lhs* rhs* e)
(do-bind lhs* rhs* (Tail e))]
[(seq e0 e1)
(make-seq (E e0) (Tail e1))]
[(conditional e0 e1 e2)
(make-conditional (P e0) (Tail e1) (Tail e2))]
[(funcall rator rands)
(handle-tail-call #f rator rands)]
[(jmpcall label rator rands)
(handle-tail-call (make-code-loc label) rator rands)]
[(forcall) (VT x)]
[(shortcut body handler)
(make-shortcut (Tail body) (Tail handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail" x)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (formals-locations args)
(let f ([regs parameter-registers] [args args])
(cond
[(null? args) '()]
[(null? regs)
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(let f ([i 1] [args args])
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(cond
[(null? args) '()]
[else
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(cons (mkfvar i)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(f (fxadd1 i) (cdr args)))]))]
[else
(cons (car regs) (f (cdr regs) (cdr args)))])))
;;;
(define locals '())
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
(define (partition-formals ls)
(let f ([regs parameter-registers] [ls ls])
(cond
[(null? regs)
(let ([flocs
(let f ([i 1] [ls ls])
(cond
[(null? ls) '()]
[else (cons (mkfvar i) (f (fxadd1 i) (cdr ls)))]))])
(values '() '() ls flocs))]
[(null? ls)
(values '() '() '() '())]
[else
(let-values ([(rargs rlocs fargs flocs)
(f (cdr regs) (cdr ls))])
(values (cons (car ls) rargs)
(cons (car regs) rlocs)
fargs flocs))])))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (ClambdaCase x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(clambda-case info body)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case info
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(case-info label args proper)
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
(let-values ([(rargs rlocs fargs flocs)
(partition-formals args)])
(set! locals rargs)
(for-each set-var-loc! fargs flocs)
(let ([body (let f ([args rargs] [locs rlocs])
(cond
[(null? args) (Tail body)]
[else
(make-seq
(make-set (car args) (car locs))
(f (cdr args) (cdr locs)))]))])
(make-clambda-case
(make-case-info label (append rlocs flocs) proper)
(make-locals locals body))))])]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Clambda x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
[(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) cp free* name)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Main x)
(set! locals '())
* before changing number of bits to 28
2007-03-11 03:40:47 -04:00
(let ([x (Tail x)])
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(make-locals locals x)))
;;;
(define (Program x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(codes code* body)
(make-codes (map Clambda code*) (Main body))]))
;;;
* libcore now compiles with chaitin
2007-02-14 19:42:36 -05:00
; (print-code x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(Program x))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(module ListySet
(make-empty-set set-member? set-add set-rem set-difference set-union
empty-set?
set->list list->set)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(define-struct set (v))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (make-empty-set) (make-set '()))
(define (set-member? x s)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
;(unless (fixnum? x) (error 'set-member? "not a fixnum" x))
(unless (set? s) (error 'set-member? "not a set" s))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(memq x (set-v s)))
(define (empty-set? s)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(unless (set? s) (error 'empty-set? "not a set" s))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(null? (set-v s)))
(define (set->list s)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(unless (set? s) (error 'set->list "not a set" s))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-v s))
(define (set-add x s)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
;(unless (fixnum? x) (error 'set-add "not a fixnum" x))
(unless (set? s) (error 'set-add "not a set" s))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(cond
[(memq x (set-v s)) s]
[else (make-set (cons x (set-v s)))]))
(define (rem x s)
(cond
[(null? s) '()]
[(eq? x (car s)) (cdr s)]
[else (cons (car s) (rem x (cdr s)))]))
(define (set-rem x s)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
;(unless (fixnum? x) (error 'set-rem "not a fixnum" x))
(unless (set? s) (error 'set-rem "not a set" s))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(make-set (rem x (set-v s))))
(define (difference s1 s2)
(cond
[(null? s2) s1]
[else (difference (rem (car s2) s1) (cdr s2))]))
(define (set-difference s1 s2)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(unless (set? s1) (error 'set-difference "not a set" s1))
(unless (set? s2) (error 'set-difference "not a set" s2))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(make-set (difference (set-v s1) (set-v s2))))
(define (set-union s1 s2)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(unless (set? s1) (error 'set-union "not a set" s1))
(unless (set? s2) (error 'set-union "not a set" s2))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(make-set (union (set-v s1) (set-v s2))))
(define (list->set ls)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
;(unless (andmap fixnum? ls) (error 'set-rem "not a list of fixnum" ls))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(make-set ls))
(define (union s1 s2)
(cond
[(null? s1) s2]
[(memq (car s1) s2) (union (cdr s1) s2)]
[else (cons (car s1) (union (cdr s1) s2))])))
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(module IntegerSet
(make-empty-set set-member? set-add set-rem set-difference
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
set-union empty-set? set->list list->set)
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(begin
* Libraries can export modules now. * libaltcogen can now be loaded.
2007-06-02 03:21:05 -04:00
(define-syntax car (identifier-syntax $car))
(define-syntax cdr (identifier-syntax $cdr))
(define-syntax fxsll (identifier-syntax $fxsll))
(define-syntax fxsra (identifier-syntax $fxsra))
(define-syntax fxlogor (identifier-syntax $fxlogor))
(define-syntax fxlogand (identifier-syntax $fxlogand))
(define-syntax fxlognot (identifier-syntax $fxlognot))
(define-syntax fx+ (identifier-syntax $fx+))
(define-syntax fxzero? (identifier-syntax $fxzero?))
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define-syntax fxeven?
(syntax-rules ()
* Libraries can export modules now. * libaltcogen can now be loaded.
2007-06-02 03:21:05 -04:00
[(_ x) ($fxzero? ($fxlogand x 1))])))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* Just realized that you don't need all var<->var conflicts to be recorded. All is needed is for a var $x$ to know some of its var conflicts as long as the other conflicts know about $x$. I'll be working on this now. I'm hoping for a 50% speedup in the assign-frame-sizes pass.
2007-03-11 18:54:15 -04:00
(define bits 28)
(define (index-of n) (fxquotient n bits))
(define (mask-of n) (fxsll 1 (fxremainder n bits)))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (make-empty-set) 0)
(define (empty-set? s) (eqv? s 0))
(define (set-member? n s)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(unless (fixnum? n) (error 'set-member? "not a fixnum" n))
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(let f ([s s] [i (index-of n)] [j (mask-of n)])
(cond
[(pair? s)
(if (fxeven? i)
(f (car s) (fxsra i 1) j)
(f (cdr s) (fxsra i 1) j))]
[(eq? i 0) (eq? j (fxlogand s j))]
[else #f])))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (set-add n s)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(unless (fixnum? n) (error 'set-add "not a fixnum" n))
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(let f ([s s] [i (index-of n)] [j (mask-of n)])
(cond
[(pair? s)
(if (fxeven? i)
(let ([a0 (car s)])
(let ([a1 (f a0 (fxsra i 1) j)])
(if (eq? a0 a1) s (cons a1 (cdr s)))))
(let ([d0 (cdr s)])
(let ([d1 (f d0 (fxsra i 1) j)])
(if (eq? d0 d1) s (cons (car s) d1)))))]
[(eq? i 0) (fxlogor s j)]
[else
(if (fxeven? i)
(cons (f s (fxsra i 1) j) 0)
(cons s (f 0 (fxsra i 1) j)))])))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (cons^ a d)
(if (and (eq? d 0) (fixnum? a))
a
(cons a d)))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (set-rem n s)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(unless (fixnum? n) (error 'set-rem "not a fixnum" n))
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(let f ([s s] [i (index-of n)] [j (mask-of n)])
(cond
[(pair? s)
(if (fxeven? i)
(let ([a0 (car s)])
(let ([a1 (f a0 (fxsra i 1) j)])
(if (eq? a0 a1) s (cons^ a1 (cdr s)))))
(let ([d0 (cdr s)])
(let ([d1 (f d0 (fxsra i 1) j)])
(if (eq? d0 d1) s (cons^ (car s) d1)))))]
[(eq? i 0) (fxlogand s (fxlognot j))]
[else s])))
(define (set-union^ s1 m2)
(if (pair? s1)
(let ([a0 (car s1)])
(let ([a1 (set-union^ a0 m2)])
(if (eq? a0 a1) s1 (cons a1 (cdr s1)))))
(fxlogor s1 m2)))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (set-union s1 s2)
(if (pair? s1)
(if (pair? s2)
(if (eq? s1 s2)
s1
(cons (set-union (car s1) (car s2))
(set-union (cdr s1) (cdr s2))))
(let ([a0 (car s1)])
(let ([a1 (set-union^ a0 s2)])
(if (eq? a0 a1) s1 (cons a1 (cdr s1))))))
(if (pair? s2)
(let ([a0 (car s2)])
(let ([a1 (set-union^ a0 s1)])
(if (eq? a0 a1) s2 (cons a1 (cdr s2)))))
(fxlogor s1 s2))))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (set-difference^ s1 m2)
(if (pair? s1)
(let ([a0 (car s1)])
(let ([a1 (set-difference^ a0 m2)])
(if (eq? a0 a1) s1 (cons^ a1 (cdr s1)))))
(fxlogand s1 (fxlognot m2))))
(define (set-difference^^ m1 s2)
(if (pair? s2)
(set-difference^^ m1 (car s2))
(fxlogand m1 (fxlognot s2))))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (set-difference s1 s2)
(if (pair? s1)
(if (pair? s2)
(if (eq? s1 s2)
0
(cons^ (set-difference (car s1) (car s2))
(set-difference (cdr s1) (cdr s2))))
(let ([a0 (car s1)])
(let ([a1 (set-difference^ a0 s2)])
(if (eq? a0 a1) s1 (cons^ a1 (cdr s1))))))
(if (pair? s2)
(set-difference^^ s1 (car s2))
(fxlogand s1 (fxlognot s2)))))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (list->set ls)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(unless (andmap fixnum? ls) (error 'list->set "not a list of fixnum" ls))
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(let f ([ls ls] [s 0])
(cond
[(null? ls) s]
[else (f (cdr ls) (set-add (car ls) s))])))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(define (set->list s)
* Just realized that you don't need all var<->var conflicts to be recorded. All is needed is for a var $x$ to know some of its var conflicts as long as the other conflicts know about $x$. I'll be working on this now. I'm hoping for a 50% speedup in the assign-frame-sizes pass.
2007-03-11 18:54:15 -04:00
(let f ([i 0] [j 1] [s s] [ac '()])
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(cond
[(pair? s)
(f i (fxsll j 1) (car s)
(f (fxlogor i j) (fxsll j 1) (cdr s) ac))]
[else
* Just realized that you don't need all var<->var conflicts to be recorded. All is needed is for a var $x$ to know some of its var conflicts as long as the other conflicts know about $x$. I'll be working on this now. I'm hoping for a 50% speedup in the assign-frame-sizes pass.
2007-03-11 18:54:15 -04:00
(let f ([i (fx* i bits)] [m s] [ac ac])
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
(cond
* Just realized that you don't need all var<->var conflicts to be recorded. All is needed is for a var $x$ to know some of its var conflicts as long as the other conflicts know about $x$. I'll be working on this now. I'm hoping for a 50% speedup in the assign-frame-sizes pass.
2007-03-11 18:54:15 -04:00
[(fxeven? m)
(if (fxzero? m)
* added a few missing instruction sequences where the dest is a memory location. * implemented integer sets (based on tree representation).
2007-03-10 19:50:24 -05:00
ac
(f (fx+ i 1) (fxsra m 1) ac))]
[else
(f (fx+ i 1) (fxsra m 1) (cons i ac))]))])))
#|IntegerSet|#)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(module ListyGraphs
(empty-graph add-edge! empty-graph? print-graph node-neighbors
delete-node!)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(import ListySet)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(define-struct graph (ls))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (empty-graph) (make-graph '()))
;;;
(define (empty-graph? g)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(andmap (lambda (x) (empty-set? (cdr x))) (graph-ls g)))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (single x)
(set-add x (make-empty-set)))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (add-edge! g x y)
(let ([ls (graph-ls g)])
(cond
[(assq x ls) =>
(lambda (p0)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(unless (set-member? y (cdr p0))
(set-cdr! p0 (set-add y (cdr p0)))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(cond
[(assq y ls) =>
(lambda (p1)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-cdr! p1 (set-add x (cdr p1))))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else
(set-graph-ls! g
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(cons (cons y (single x)) ls))])))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(assq y ls) =>
(lambda (p1)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-cdr! p1 (set-add x (cdr p1)))
(set-graph-ls! g (cons (cons x (single y)) ls)))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else
(set-graph-ls! g
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* (cons x (single y))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(cons y (single x))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
ls))])))
(define (print-graph g)
(printf "G={\n")
(parameterize ([print-gensym 'pretty])
(for-each (lambda (x)
(let ([lhs (car x)] [rhs* (cdr x)])
(printf " ~s => ~s\n"
(unparse lhs)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(map unparse (set->list rhs*)))))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(graph-ls g)))
(printf "}\n"))
(define (node-neighbors x g)
(cond
[(assq x (graph-ls g)) => cdr]
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[else (make-empty-set)]))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (delete-node! x g)
(let ([ls (graph-ls g)])
(cond
[(assq x ls) =>
(lambda (p)
(for-each (lambda (y)
(let ([p (assq y ls)])
(set-cdr! p (set-rem x (cdr p)))))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set->list (cdr p)))
(set-cdr! p (make-empty-set)))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else (void)])))
;;;
#|ListyGraphs|#)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
* Can load altcogen.
2007-06-02 21:55:40 -04:00
(module IntegerGraphs
(empty-graph add-edge! empty-graph? print-graph node-neighbors
delete-node!)
(import IntegerSet)
;;;
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(define-struct graph (ls))
* Can load altcogen.
2007-06-02 21:55:40 -04:00
;;;
(define (empty-graph) (make-graph '()))
;;;
(define (empty-graph? g)
(andmap (lambda (x) (empty-set? (cdr x))) (graph-ls g)))
;;;
(define (single x)
(set-add x (make-empty-set)))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* Can load altcogen.
2007-06-02 21:55:40 -04:00
(define (add-edge! g x y)
(let ([ls (graph-ls g)])
(cond
[(assq x ls) =>
(lambda (p0)
(unless (set-member? y (cdr p0))
(set-cdr! p0 (set-add y (cdr p0)))
(cond
[(assq y ls) =>
(lambda (p1)
(set-cdr! p1 (set-add x (cdr p1))))]
[else
(set-graph-ls! g
(cons (cons y (single x)) ls))])))]
[(assq y ls) =>
(lambda (p1)
(set-cdr! p1 (set-add x (cdr p1)))
(set-graph-ls! g (cons (cons x (single y)) ls)))]
[else
(set-graph-ls! g
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* (cons x (single y))
* Can load altcogen.
2007-06-02 21:55:40 -04:00
(cons y (single x))
ls))])))
(define (print-graph g)
(printf "G={\n")
(parameterize ([print-gensym 'pretty])
(for-each (lambda (x)
(let ([lhs (car x)] [rhs* (cdr x)])
(printf " ~s => ~s\n"
(unparse lhs)
(map unparse (set->list rhs*)))))
(graph-ls g)))
(printf "}\n"))
(define (node-neighbors x g)
(cond
[(assq x (graph-ls g)) => cdr]
[else (make-empty-set)]))
* '#!eof no longer signals an assembler error - bug reported by micheal adams in person.
2007-11-11 01:04:07 -05:00
;;;
* Can load altcogen.
2007-06-02 21:55:40 -04:00
(define (delete-node! x g)
(let ([ls (graph-ls g)])
(cond
[(assq x ls) =>
(lambda (p)
(for-each (lambda (y)
(let ([p (assq y ls)])
(set-cdr! p (set-rem x (cdr p)))))
(set->list (cdr p)))
(set-cdr! p (make-empty-set)))]
[else (void)])))
;;;
#|IntegerGraphs|#)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(module conflict-helpers
(empty-var-set rem-var add-var union-vars mem-var? for-each-var init-vars!
empty-nfv-set rem-nfv add-nfv union-nfvs mem-nfv? for-each-nfv init-nfv!
empty-frm-set rem-frm add-frm union-frms mem-frm?
empty-reg-set rem-reg add-reg union-regs mem-reg?
reg?)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(import IntegerSet)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(begin
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(define (add-frm x s) (set-add (fvar-idx x) s))
(define (rem-nfv x s)
* Added remq, remp, remv, and remove
2007-09-10 16:33:05 -04:00
(remq1 x s))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (init-var! x i)
(set-var-index! x i)
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(set-var-var-move! x (empty-var-set))
(set-var-reg-move! x (empty-reg-set))
(set-var-frm-move! x (empty-frm-set))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(set-var-var-conf! x (empty-var-set))
(set-var-reg-conf! x (empty-reg-set))
(set-var-frm-conf! x (empty-frm-set)))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (init-vars! ls)
(let f ([ls ls] [i 0])
(unless (null? ls)
(init-var! (car ls) i)
(f (cdr ls) (fxadd1 i)))))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (init-nfv! x)
(set-nfv-frm-conf! x (empty-frm-set))
(set-nfv-nfv-conf! x (empty-nfv-set))
(set-nfv-var-conf! x (empty-var-set)))
(define (reg? x) (symbol? x))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (empty-var-set) (make-empty-set))
(define (add-var x s) (set-add (var-index x) s))
(define (mem-var? x s) (set-member? (var-index x) s))
(define (rem-var x s) (set-rem (var-index x) s))
(define (union-vars s1 s2) (set-union s1 s2))
(define (for-each-var s varvec f)
(for-each (lambda (i) (f (vector-ref varvec i)))
(set->list s)))
(define (empty-reg-set) (make-empty-set))
(define (add-reg x s) (set-add (register-index x) s))
(define (rem-reg x s) (set-rem (register-index x) s))
(define (mem-reg? x s) (set-member? (register-index x) s))
(define (union-regs s1 s2) (set-union s1 s2))
(define (empty-frm-set) (make-empty-set))
(define (mem-frm? x s) (set-member? (fvar-idx x) s))
(define (rem-frm x s) (set-rem (fvar-idx x) s))
(define (union-frms s1 s2) (set-union s1 s2))
(define (empty-nfv-set) '())
(define (add-nfv x s)
(cond
[(memq x s) s]
[else (cons x s)]))
(define (mem-nfv? x s)
(memq x s))
(define (union-nfvs s1 s2)
(let f ([s1 s1] [s2 s2])
(cond
[(null? s1) s2]
[(memq (car s1) s2) (f (cdr s1) s2)]
[else (cons (car s1) (f (cdr s1) s2))])))
(define (for-each-nfv s f)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(for-each f s))))
(define (uncover-frame-conflicts x varvec)
(import IntegerSet)
(import conflict-helpers)
(define who 'uncover-frame-conflicts)
(define spill-set (make-empty-set))
(define (mark-reg/vars-conf! r vs)
(for-each-var vs varvec
(lambda (v)
(set-var-reg-conf! v
(add-reg r (var-reg-conf v))))))
(define (mark-frm/vars-conf! f vs)
(for-each-var vs varvec
(lambda (v)
(set-var-frm-conf! v
(add-frm f (var-frm-conf v))))))
(define (mark-frm/nfvs-conf! f ns)
(for-each-nfv ns
(lambda (n)
(set-nfv-frm-conf! n
(add-frm f (nfv-frm-conf n))))))
(define (mark-var/vars-conf! v vs)
(for-each-var vs varvec
(lambda (w)
(set-var-var-conf! w
(add-var v (var-var-conf w)))))
(set-var-var-conf! v
(union-vars vs (var-var-conf v))))
(define (mark-var/frms-conf! v fs)
(set-var-frm-conf! v
(union-frms fs (var-frm-conf v))))
(define (mark-var/regs-conf! v rs)
(set-var-reg-conf! v
(union-regs rs (var-reg-conf v))))
(define (mark-var/nfvs-conf! v ns)
(for-each-nfv ns
(lambda (n)
(set-nfv-var-conf! n
(add-var v (nfv-var-conf n))))))
(define (mark-nfv/vars-conf! n vs)
(set-nfv-var-conf! n
(union-vars vs (nfv-var-conf n))))
(define (mark-nfv/frms-conf! n fs)
(set-nfv-frm-conf! n
(union-frms fs (nfv-frm-conf n))))
(define (mark-nfv/nfvs-conf! n ns)
(set-nfv-nfv-conf! n
(union-nfvs ns (nfv-nfv-conf n)))
(for-each-nfv ns
(lambda (m)
(set-nfv-nfv-conf! m
(add-nfv n (nfv-nfv-conf m))))))
(define (mark-var/var-move! x y)
(set-var-var-move! x
(add-var y (var-var-move x)))
(set-var-var-move! y
(add-var x (var-var-move y))))
(define (mark-var/frm-move! x y)
(set-var-frm-move! x
(add-frm y (var-frm-move x))))
(define (mark-var/reg-move! x y)
(set-var-reg-move! x
(add-reg y (var-reg-move x))))
(define (const? x)
(or (constant? x)
(code-loc? x)))
(define (R x vs rs fs ns)
(cond
[(const? x) (values vs rs fs ns)]
[(reg? x)
(values vs (add-reg x rs) fs ns)]
[(fvar? x)
(values vs rs (add-frm x fs) ns)]
[(var? x)
(values (add-var x vs) rs fs ns)]
[(nfv? x)
(values vs rs fs (add-nfv x ns))]
[(disp? x)
(let-values ([(vs rs fs ns) (R (disp-s0 x) vs rs fs ns)])
(R (disp-s1 x) vs rs fs ns))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid R" x)]))
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(define (R* ls vs rs fs ns)
(cond
[(null? ls) (values vs rs fs ns)]
[else
(let-values ([(vs rs fs ns) (R (car ls) vs rs fs ns)])
(R* (cdr ls) vs rs fs ns))]))
(define (E x vs rs fs ns)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(seq e0 e1)
(let-values ([(vs rs fs ns) (E e1 vs rs fs ns)])
(E e0 vs rs fs ns))]
[(conditional e0 e1 e2)
(let-values ([(vs1 rs1 fs1 ns1) (E e1 vs rs fs ns)]
[(vs2 rs2 fs2 ns2) (E e2 vs rs fs ns)])
(P e0
vs1 rs1 fs1 ns1
vs2 rs2 fs2 ns2
(union-vars vs1 vs2)
(union-regs rs1 rs2)
(union-frms fs1 fs2)
(union-nfvs ns1 ns2)))]
[(asm-instr op d s)
(case op
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(move move-byte load32)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(cond
[(reg? d)
(cond
[(not (mem-reg? d rs))
(set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[(or (const? s) (disp? s) (reg? s))
(let ([rs (rem-reg d rs)])
(mark-reg/vars-conf! d vs)
(R s vs rs fs ns))]
[(var? s)
(let ([rs (rem-reg d rs)]
[vs (rem-var s vs)])
(mark-var/reg-move! s d)
(mark-reg/vars-conf! d vs)
(values (add-var s vs) rs fs ns))]
[(fvar? s)
(let ([rs (rem-reg d rs)])
(mark-reg/vars-conf! d vs)
(values vs rs (add-frm s fs) ns))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid rs" (unparse x))])]
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(fvar? d)
(cond
[(not (mem-frm? d fs))
(set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[(or (const? s) (disp? s) (reg? s))
(let ([fs (rem-frm d fs)])
(mark-frm/vars-conf! d vs)
(mark-frm/nfvs-conf! d ns)
(R s vs rs fs ns))]
[(var? s)
(let ([fs (rem-frm d fs)]
[vs (rem-var s vs)])
(mark-var/frm-move! s d)
(mark-frm/vars-conf! d vs)
(mark-frm/nfvs-conf! d ns)
(values (add-var s vs) rs fs ns))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid fs" s)])]
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(var? d)
(cond
[(not (mem-var? d vs))
(set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[(or (disp? s) (constant? s))
(let ([vs (rem-var d vs)])
(mark-var/vars-conf! d vs)
(mark-var/frms-conf! d fs)
(mark-var/regs-conf! d rs)
(mark-var/nfvs-conf! d ns)
(R s vs rs fs ns))]
[(reg? s)
(let ([vs (rem-var d vs)]
[rs (rem-reg s rs)])
(mark-var/reg-move! d s)
(mark-var/vars-conf! d vs)
(mark-var/frms-conf! d fs)
(mark-var/regs-conf! d rs)
(mark-var/nfvs-conf! d ns)
(values vs (add-reg s rs) fs ns))]
[(var? s)
(let ([vs (rem-var d (rem-var s vs))])
(mark-var/var-move! d s)
(mark-var/vars-conf! d vs)
(mark-var/frms-conf! d fs)
(mark-var/regs-conf! d rs)
(mark-var/nfvs-conf! d ns)
(values (add-var s vs) rs fs ns))]
[(fvar? s)
(let ([vs (rem-var d vs)]
[fs (rem-frm s fs)])
(mark-var/frm-move! d s)
(mark-var/vars-conf! d vs)
(mark-var/frms-conf! d fs)
(mark-var/regs-conf! d rs)
(mark-var/nfvs-conf! d ns)
(values vs rs (add-frm s fs) ns))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid vs" s)])]
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(nfv? d)
(cond
[(not (mem-nfv? d ns)) (error who "dead nfv")]
[(or (disp? s) (constant? s) (reg? s))
(let ([ns (rem-nfv d ns)])
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(R s vs rs fs ns))]
[(var? s)
(let ([ns (rem-nfv d ns)]
[vs (rem-var s vs)])
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(values (add-var s vs) rs fs ns))]
[(fvar? s)
(let ([ns (rem-nfv d ns)]
[fs (rem-frm s fs)])
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(values vs rs (add-frm s fs) ns))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid ns" s)])]
[else (error who "invalid d" d)])]
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(int-/overflow int+/overflow int*/overflow)
(let ([v (exception-live-set)])
(unless (vector? v)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "unbound exception" x v))
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(let ([vs (union-vars vs (vector-ref v 0))]
[rs (union-regs rs (vector-ref v 1))]
[fs (union-frms fs (vector-ref v 2))]
[ns (union-nfvs ns (vector-ref v 3))])
(cond
[(var? d)
(cond
[(not (mem-var? d vs))
(set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[else
(let ([vs (rem-var d vs)])
(mark-var/vars-conf! d vs)
(mark-var/frms-conf! d fs)
(mark-var/nfvs-conf! d ns)
(mark-var/regs-conf! d rs)
(R s (add-var d vs) rs fs ns))])]
[(reg? d)
(cond
[(not (mem-reg? d rs))
(values vs rs fs ns)]
[else
(let ([rs (rem-reg d rs)])
(mark-reg/vars-conf! d vs)
(R s vs (add-reg d rs) fs ns))])]
[(nfv? d)
(cond
[(not (mem-nfv? d ns)) (error who "dead nfv")]
[else
(let ([ns (rem-nfv d ns)])
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(R s vs rs fs (add-nfv d ns)))])]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid op d" (unparse x))])))]
fxarithmetic-shift-left now detects overflows properly.
2008-03-18 00:49:24 -04:00
[(logand logor logxor sll sra srl int+ int- int* bswap!
sll/overflow)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(cond
[(var? d)
(cond
[(not (mem-var? d vs))
(set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[else
(let ([vs (rem-var d vs)])
(mark-var/vars-conf! d vs)
(mark-var/frms-conf! d fs)
(mark-var/nfvs-conf! d ns)
(mark-var/regs-conf! d rs)
(R s (add-var d vs) rs fs ns))])]
[(reg? d)
(cond
[(not (mem-reg? d rs))
* Fixed bug 160483: described as "incorrect number of arguments" reported as "not a function" - The real reason was in the register allocator, where one live variable (the memmory size of the bytevector) was not marked live across the call to do-overflow. When the overflow returned, the value of that variable (which was in the %ebx register) was trashed, leading to an incorrect bump in the allocation pointer. - Note to self, never blame anything on cache coherency again!
2007-11-06 17:04:27 -05:00
(set-asm-instr-op! x 'nop)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(values vs rs fs ns)]
[else
(let ([rs (rem-reg d rs)])
(mark-reg/vars-conf! d vs)
(R s vs (add-reg d rs) fs ns))])]
[(nfv? d)
(cond
[(not (mem-nfv? d ns)) (error who "dead nfv")]
[else
(let ([ns (rem-nfv d ns)])
(mark-nfv/vars-conf! d vs)
(mark-nfv/frms-conf! d fs)
(R s vs rs fs (add-nfv d ns)))])]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid op d" (unparse x))])]
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(idiv)
(mark-reg/vars-conf! eax vs)
(mark-reg/vars-conf! edx vs)
(R s vs (add-reg eax (add-reg edx rs)) fs ns)]
[(cltd)
(mark-reg/vars-conf! edx vs)
(R s vs (rem-reg edx rs) fs ns)]
Passing 709 tests in 64-bit mode
2008-04-12 15:06:55 -04:00
[(mset mset32 bset bset/c bset/h
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! fl:from-int
fl:shuffle fl:load-single fl:store-single)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(R* (list s d) vs rs fs ns)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect op" (unparse x))])]
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(ntcall target value args mask size)
(set! spill-set (union-vars vs spill-set))
(for-each-var vs varvec (lambda (x) (set-var-loc! x #t)))
(R* args vs (empty-reg-set) fs ns)]
[(nframe nfvs live body)
(for-each init-nfv! nfvs)
(set-nframe-live! x (vector vs fs ns))
(E body vs rs fs ns)]
[(primcall op args)
(case op
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(nop fl:double->single fl:single->double) (values vs rs fs ns)]
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
[(interrupt incr/zero?)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(let ([v (exception-live-set)])
(unless (vector? v)
* fixed a HUGE bug in optimize-letrec. * fixed two minor bugs in the code generators for - and + * added a constant-folder for "length"
2007-06-06 03:14:07 -04:00
(error who "unbound exception2"))
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(values (vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect op" op)])]
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(shortcut body handler)
(let-values ([(vsh rsh fsh nsh) (E handler vs rs fs ns)])
(parameterize ([exception-live-set
(vector vsh rsh fsh nsh)])
(E body vs rs fs ns)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" (unparse x))]))
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(define (P x vst rst fst nst
vsf rsf fsf nsf
vsu rsu fsu nsu)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(seq e0 e1)
(let-values ([(vs rs fs ns)
(P e1 vst rst fst nst
vsf rsf fsf nsf
vsu rsu fsu nsu)])
(E e0 vs rs fs ns))]
[(conditional e0 e1 e2)
(let-values ([(vs1 rs1 fs1 ns1)
(P e1 vst rst fst nst
vsf rsf fsf nsf
vsu rsu fsu nsu)]
[(vs2 rs2 fs2 ns2)
(P e2 vst rst fst nst
vsf rsf fsf nsf
vsu rsu fsu nsu)])
(P e0
vs1 rs1 fs1 ns1
vs2 rs2 fs2 ns2
(union-vars vs1 vs2)
(union-regs rs1 rs2)
(union-frms fs1 fs2)
(union-nfvs ns1 ns2)))]
[(constant t)
(if t
(values vst rst fst nst)
(values vsf rsf fsf nsf))]
[(asm-instr op d s)
(R* (list d s) vsu rsu fsu nsu)]
[(shortcut body handler)
(let-values ([(vsh rsh fsh nsh)
(P handler vst rst fst nst
vsf rsf fsf nsf
vsu rsu fsu nsu)])
(parameterize ([exception-live-set
(vector vsh rsh fsh nsh)])
(P body vst rst fst nst
vsf rsf fsf nsf
vsu rsu fsu nsu)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid pred" (unparse x))]))
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(define (T x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(seq e0 e1)
(let-values ([(vs rs fs ns) (T e1)])
(E e0 vs rs fs ns))]
[(conditional e0 e1 e2)
(let-values ([(vs1 rs1 fs1 ns1) (T e1)]
[(vs2 rs2 fs2 ns2) (T e2)])
(P e0
vs1 rs1 fs1 ns1
vs2 rs2 fs2 ns2
(union-vars vs1 vs2)
(union-regs rs1 rs2)
(union-frms fs1 fs2)
(union-nfvs ns1 ns2)))]
[(primcall op arg*)
(case op
[(return indirect-jump direct-jump)
(R* arg* (empty-var-set)
(empty-reg-set)
(empty-frm-set)
(empty-nfv-set))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail op" x)])]
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
[(shortcut body handler)
(let-values ([(vsh rsh fsh nsh) (T handler)])
(parameterize ([exception-live-set
(vector vsh rsh fsh nsh)])
(T body)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail" x)]))
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(define exception-live-set
(make-parameter #f))
(T x)
spill-set)
(module (assign-frame-sizes)
;;; assign-frame-sizes module
(define indent (make-parameter 0))
(import IntegerSet)
(import conflict-helpers)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (rewrite x varvec)
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(define who 'rewrite)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (assign x)
* deleting old list-based set representation.
2007-03-10 21:01:41 -05:00
(let ()
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (assign-any)
(let ([frms (var-frm-conf x)]
[vars (var-var-conf x)])
(let f ([i 1])
(cond
* important realization that set->list is perhaps the most expensive operation on sets. Working on eliminating most uses of set->list.
2007-03-11 20:00:08 -04:00
[(set-member? i frms) (f (fxadd1 i))]
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[else
(let ([fv (mkfvar i)])
(set-var-loc! x fv)
(for-each-var vars varvec
(lambda (var)
(set-var-frm-conf! var
(add-frm fv (var-frm-conf var)))))
fv)]))))
(define (assign-move x)
(let ([mr (set->list
(set-difference
(var-frm-move x)
(var-frm-conf x)))])
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(cond
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[(null? mr) #f]
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[else
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(let ([fv (mkfvar (car mr))])
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(set-var-loc! x fv)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(for-each-var (var-var-conf x) varvec
(lambda (var)
(set-var-frm-conf! var
(add-frm fv (var-frm-conf var)))))
(for-each-var (var-var-move x) varvec
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(lambda (var)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-var-frm-move! var
* assign-frame-sizes is as complete as could be (time for assigning libcompile.ss dropped from ~5 secs to 1.8 secs).
2007-03-11 20:55:43 -04:00
(add-frm fv (var-frm-move var)))))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
fv)])))
(or (assign-move x)
(assign-any))))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (NFE idx mask x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(seq e0 e1)
(let ([e0 (E e0)])
(make-seq e0 (NFE idx mask e1)))]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(ntcall target value args mask^ size)
(make-ntcall target value
(map (lambda (x)
(cond
[(symbol? x) x]
[(nfv? x) (nfv-loc x)]
[else (error who "invalid arg")]))
args)
mask idx)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid NF effect" x)]))
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(define (Var x)
(cond
[(var-loc x) =>
(lambda (loc)
(if (fvar? loc)
loc
(assign x)))]
[else x]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (R x)
(cond
[(or (constant? x) (reg? x) (fvar? x)) x]
[(nfv? x)
(or (nfv-loc x)
(error who "unassigned nfv"))]
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(var? x) (Var x)]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(disp? x)
(make-disp (R (disp-s0 x)) (R (disp-s1 x)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid R" (unparse x))]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (E x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(seq e0 e1)
(let ([e0 (E e0)])
(make-seq e0 (E e1)))]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op d s)
(case op
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(move move-byte load32)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(let ([d (R d)] [s (R s)])
(cond
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(eq? d s)
(make-primcall 'nop '())]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[else
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
(make-asm-instr op d s)]))]
Passing 709 tests in 64-bit mode
2008-04-12 15:06:55 -04:00
[(logand logor logxor int+ int- int* mset bset mset32 bset/c bset/h
* bytevector-ieee-double-ref/set! now work
2007-11-07 04:54:54 -05:00
sll sra srl bswap!
* Added native support for $fl+, $fl-, $fl*, $fl/
2007-06-15 01:53:34 -04:00
cltd idiv int-/overflow int+/overflow int*/overflow
* $fixnum->flonum now works.
2007-06-18 07:29:39 -04:00
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fxarithmetic-shift-left now detects overflows properly.
2008-03-18 00:49:24 -04:00
fl:from-int fl:shuffle fl:load-single fl:store-single
sll/overflow)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(make-asm-instr op (R d) (R s))]
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
[(nop) (make-primcall 'nop '())]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid op" op)])]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(nframe vars live body)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(let ([live-frms1
(map (lambda (i) (Var (vector-ref varvec i)))
(set->list (vector-ref live 0)))]
[live-frms2 (set->list (vector-ref live 1))]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[live-nfvs (vector-ref live 2)])
(define (max-frm ls i)
(cond
[(null? ls) i]
[else
(max-frm (cdr ls)
(max i (fvar-idx (car ls))))]))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (max-ls ls i)
(cond
[(null? ls) i]
[else
(max-ls (cdr ls) (max i (car ls)))]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (max-nfv ls i)
(cond
[(null? ls) i]
[else
(let ([loc (nfv-loc (car ls))])
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(unless (fvar? loc) (error 'max-nfv "not assigned"))
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(max-nfv (cdr ls) (max i (fvar-idx loc))))]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (actual-frame-size vars i)
* eliminated a few instances of set-rem and set->list.
2007-03-11 20:39:21 -04:00
(define (var-conflict? i vs)
(ormap (lambda (xi)
(let ([loc (var-loc (vector-ref varvec xi))])
(and (fvar? loc)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(fx= i (fvar-idx loc)))))
* eliminated a few instances of set-rem and set->list.
2007-03-11 20:39:21 -04:00
(set->list vs)))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (frame-size-ok? i vars)
(or (null? vars)
* eliminated a few instances of set-rem and set->list.
2007-03-11 20:39:21 -04:00
(let ([x (car vars)])
(and (not (set-member? i (nfv-frm-conf x)))
(not (var-conflict? i (nfv-var-conf x)))
(frame-size-ok? (fxadd1 i) (cdr vars))))))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(cond
[(frame-size-ok? i vars) i]
[else (actual-frame-size vars (fxadd1 i))]))
(define (assign-frame-vars! vars i)
(unless (null? vars)
(let ([v (car vars)] [fv (mkfvar i)])
(set-nfv-loc! v fv)
* eliminated a few instances of set-rem and set->list.
2007-03-11 20:39:21 -04:00
;(for-each
; (lambda (j)
; (when (fx= j i)
; (error who "invalid assignment")))
; (set->list (nfv-frm-conf v)))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(for-each
(lambda (x)
(let ([loc (nfv-loc x)])
(cond
[loc
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(when (fx= (fvar-idx loc) i)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(error who "invalid assignment"))]
[else
(set-nfv-nfv-conf! x
(rem-nfv v (nfv-nfv-conf x)))
(set-nfv-frm-conf! x
(add-frm fv (nfv-frm-conf x)))])))
(nfv-nfv-conf v))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(for-each-var (nfv-var-conf v) varvec
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(lambda (x)
(let ([loc (var-loc x)])
(cond
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(fvar? loc)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(when (fx= (fvar-idx loc) i)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(error who "invalid assignment"))]
[else
(set-var-frm-conf! x
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(add-frm fv (var-frm-conf x)))])))))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(assign-frame-vars! (cdr vars) (fxadd1 i))))
(define (make-mask n)
(let ([v (make-vector (fxsra (fx+ n 7) 3) 0)])
(define (set-bit idx)
(let ([q (fxsra idx 3)]
[r (fxlogand idx 7)])
(vector-set! v q
(fxlogor (vector-ref v q) (fxsll 1 r)))))
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(for-each (lambda (x) (set-bit (fvar-idx x))) live-frms1)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(for-each set-bit live-frms2)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(for-each (lambda (x)
(let ([loc (nfv-loc x)])
(when loc
(set-bit (fvar-idx loc)))))
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
live-nfvs) v))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(let ([i (actual-frame-size vars
(fx+ 2
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
(max-frm live-frms1
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(max-nfv live-nfvs
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(max-ls live-frms2 0)))))])
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(assign-frame-vars! vars i)
(NFE (fxsub1 i) (make-mask (fxsub1 i)) body)))]
[(primcall op args)
(case op
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(nop interrupt incr/zero? fl:double->single
fl:single->double) x]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect prim" op)])]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
(make-shortcut (E body) (E handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" (unparse x))]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (P x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(seq e0 e1)
(let ([e0 (E e0)])
(make-seq e0 (P e1)))]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))]
[(asm-instr op d s) (make-asm-instr op (R d) (R s))]
[(constant) x]
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[(shortcut body handler)
(make-shortcut (P body) (P handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid pred" (unparse x))]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(define (T x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(seq e0 e1)
(let ([e0 (E e0)])
(make-seq e0 (T e1)))]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))]
[(primcall op args) x]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
(make-shortcut (T body) (T handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail" (unparse x))]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(T x))
;;;
(define (Main x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(locals vars body)
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(init-vars! vars)
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
(let ([varvec (list->vector vars)])
(let ([call-live* (uncover-frame-conflicts body varvec)])
(let ([body (rewrite body varvec)])
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(make-locals
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
(cons varvec
(let f ([vars vars])
(cond
[(null? vars) '()]
[(var-loc (car vars)) (f (cdr vars))]
[else (cons (car vars) (f (cdr vars)))])))
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
body))))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error 'assign-frame-sizes "invalid main" x)]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
;;;
(define (ClambdaCase x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(clambda-case info body)
(make-clambda-case info (Main body))]))
;;;
(define (Clambda x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
[(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) cp free* name)]))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
;;;
(define (Program x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(codes code* body)
(make-codes (map Clambda code*) (Main body))]))
;;;
(define (assign-frame-sizes x)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(let ([v (Program x)])
v)))
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(module (color-by-chaitin)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(import ListySet)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(import ListyGraphs)
* Can load altcogen.
2007-06-02 21:55:40 -04:00
;(import IntegerSet)
;(import IntegerGraphs)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(define (set-for-each f s)
(for-each f (set->list s)))
;;;
* removed the reg? argument to build-graph. Reg? was needed when build-graph was used for constructing both frame conflicts and register conflicts. Now, it's only used for register conflicts so reg? is no longer needed.
2007-06-05 23:10:28 -04:00
(define (build-graph x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define who 'build-graph)
(define g (empty-graph))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (R* ls)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(cond
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[(null? ls) (make-empty-set)]
[else (set-union (R (car ls)) (R* (cdr ls)))]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (R x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[(constant) (make-empty-set)]
[(var) (list->set (list x))]
[(disp s0 s1) (set-union (R s0) (R s1))]
* removed the reg? argument to build-graph. Reg? was needed when build-graph was used for constructing both frame conflicts and register conflicts. Now, it's only used for register conflicts so reg? is no longer needed.
2007-06-05 23:10:28 -04:00
[(fvar) (make-empty-set)]
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[(code-loc) (make-empty-set)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[else
(cond
* removed the reg? argument to build-graph. Reg? was needed when build-graph was used for constructing both frame conflicts and register conflicts. Now, it's only used for register conflicts so reg? is no longer needed.
2007-06-05 23:10:28 -04:00
[(symbol? x)
small bug fix in assembler for code like (movl reg (disp reg reg))
2007-12-31 03:02:12 -05:00
(if (memq x all-registers)
* removed the reg? argument to build-graph. Reg? was needed when build-graph was used for constructing both frame conflicts and register conflicts. Now, it's only used for register conflicts so reg? is no longer needed.
2007-06-05 23:10:28 -04:00
(set-add x (make-empty-set))
(make-empty-set))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid R" x)])]))
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
;;; build effect
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (E x s)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op d v)
(case op
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(move load32)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(let ([s (set-rem d s)])
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (R v) s))]
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
[(move-byte)
(let ([s (set-rem d s)])
(set-for-each (lambda (y) (add-edge! g d y)) s)
* Added ratnum cases to binary*.
2007-06-08 03:18:36 -04:00
(when (var? d)
(for-each (lambda (r) (add-edge! g d r)) non-8bit-registers))
(when (var? v)
(for-each (lambda (r) (add-edge! g v r)) non-8bit-registers))
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
(set-union (R v) s))]
* optimized symbol calls using the symbol-function field. * added error checks for applying nonprocedures.
2007-02-25 21:29:28 -05:00
[(int-/overflow int+/overflow int*/overflow)
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
(unless (exception-live-set)
(error who "uninitialized live set"))
(let ([s (set-rem d (set-union s (exception-live-set)))])
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (set-union (R v) (R d)) s))]
fxarithmetic-shift-left now detects overflows properly.
2008-03-18 00:49:24 -04:00
[(logand logxor int+ int- int* logor sll sra srl bswap!
sll/overflow)
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(let ([s (set-rem d s)])
* Cleanup of some junk code in color-by-chaitin
2007-06-05 18:16:34 -04:00
(set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (set-union (R v) (R d)) s))]
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[(bset/c)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-union (set-union (R v) (R d)) s)]
Passing 709 tests in 64-bit mode
2008-04-12 15:06:55 -04:00
[(bset/h bset)
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
(when (var? v)
(for-each (lambda (r) (add-edge! g v r))
non-8bit-registers))
(set-union (set-union (R v) (R d)) s)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(cltd)
(let ([s (set-rem edx s)])
(when (register? edx)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-for-each (lambda (y) (add-edge! g edx y)) s))
(set-union (R eax) s))]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(idiv)
(let ([s (set-rem eax (set-rem edx s))])
(when (register? eax)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-for-each
(lambda (y) (add-edge! g eax y) (add-edge! g edx y))
s))
(set-union (set-union (R eax) (R edx))
(set-union (R v) s)))]
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(mset mset32 fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
fl:from-int fl:shuffle fl:store-single
fl:load-single)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-union (R v) (set-union (R d) s))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" x)])]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (E e0 (E e1 s))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(let ([s1 (E e1 s)] [s2 (E e2 s)])
(P e0 s1 s2 (set-union s1 s2)))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(ntcall targ value args mask size)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-union (R* args) s)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(primcall op arg*)
(case op
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(nop fl:single->double fl:double->single) s]
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
[(interrupt incr/zero?)
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
(or (exception-live-set) (error who "uninitialized exception"))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect primcall" op)])]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
(let ([s2 (E handler s)])
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
(parameterize ([exception-live-set s2])
(E body s)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" (unparse x))]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x st sf su)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant c) (if c st sf)]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(seq e0 e1)
(E e0 (P e1 st sf su))]
[(conditional e0 e1 e2)
(let ([s1 (P e1 st sf su)] [s2 (P e2 st sf su)])
(P e0 s1 s2 (set-union s1 s2)))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op s0 s1)
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set-union (set-union (R s0) (R s1)) su)]
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[(shortcut body handler)
(let ([s2 (P handler st sf su)])
(parameterize ([exception-live-set s2])
(P body st sf su)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid pred" (unparse x))]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (T x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(let ([s1 (T e1)] [s2 (T e2)])
(P e0 s1 s2 (set-union s1 s2)))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(primcall op rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(R* rands)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (E e0 (T e1))]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
(let ([s2 (T handler)])
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
(parameterize ([exception-live-set s2])
(T body)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail" (unparse x))]))
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
(define exception-live-set (make-parameter #f))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(let ([s (T x)])
* fixed bug in the graph construction that caused the operand of idivl not to be added to the live set.
2007-03-02 00:41:28 -05:00
;(pretty-print (unparse x))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;(print-graph g)
g))
;;;
(define (color-graph sp* un* g)
(define (find-low-degree ls g)
(cond
[(null? ls) #f]
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[(fx< (length (set->list (node-neighbors (car ls) g)))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(length all-registers))
(car ls)]
[else (find-low-degree (cdr ls) g)]))
(define (find-color/maybe x confs env)
(let ([cr (map (lambda (x)
(cond
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(symbol? x) x]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(assq x env) => cdr]
[else #f]))
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set->list confs))])
(let ([r* (set->list
(set-difference
(list->set all-registers)
(list->set cr)))])
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(if (null? r*)
#f
(car r*)))))
(define (find-color x confs env)
(or (find-color/maybe x confs env)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error 'find-color "cannot find color for" x)))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(cond
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[(and (empty-set? sp*) (empty-set? un*))
(values '() (make-empty-set) '())]
[(find-low-degree (set->list un*) g) =>
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(lambda (un)
(let ([n* (node-neighbors un g)])
(delete-node! un g)
(let-values ([(spills sp* env)
(color-graph sp* (set-rem un un*) g)])
(let ([r (find-color un n* env)])
(values spills sp*
(cons (cons un r) env))))))]
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[(find-low-degree (set->list sp*) g) =>
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(lambda (sp)
(let ([n* (node-neighbors sp g)])
(delete-node! sp g)
(let-values ([(spills sp* env)
(color-graph (set-rem sp sp*) un* g)])
(let ([r (find-color sp n* env)])
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(values spills (set-add sp sp*)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(cons (cons sp r) env))))))]
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
[(pair? (set->list sp*))
(let ([sp (car (set->list sp*))])
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(let ([n* (node-neighbors sp g)])
(delete-node! sp g)
(let-values ([(spills sp* env)
(color-graph (set-rem sp sp*) un* g)])
(let ([r (find-color/maybe sp n* env)])
(if r
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(values spills (set-add sp sp*)
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(cons (cons sp r) env))
(values (cons sp spills) sp* env))))))]
* altcogen passes 1.8
2007-02-11 18:06:04 -05:00
[else (error 'color-graph "whoaaa")]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
(define (substitute env x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define who 'substitute)
(define (Var x)
(cond
[(assq x env) => cdr]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else x]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (Rhs x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(var) (Var x)]
[(primcall op rand*)
(make-primcall op (map Rand rand*))]
[else x]))
(define (Rand x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(var) (Var x)]
[else x]))
(define (Lhs x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(var) (Var x)]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(nfv confs loc)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(or loc (error who "LHS not set" x))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else x]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (D x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(constant) x]
[(var) (Var x)]
[(fvar) x]
[else
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(if (symbol? x) x (error who "invalid D" x))]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (R x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(constant) x]
[(var) (Var x)]
[(fvar) x]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[(nfv c loc)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(or loc (error who "unset nfv in R" x))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(disp s0 s1) (make-disp (D s0) (D s1))]
[else
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(if (symbol? x) x (error who "invalid R" x))]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;; substitute effect
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (E x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (make-seq (E e0) (E e1))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op x v)
(make-asm-instr op (R x) (R v))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(primcall op rands)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(make-primcall op (map R rands))]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(ntcall) x]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
(make-shortcut (E body) (E handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" (unparse x))]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant) x]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op x v)
(make-asm-instr op (R x) (R v))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))]
[(seq e0 e1) (make-seq (E e0) (P e1))]
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[(shortcut body handler)
(make-shortcut (P body) (P handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid pred" (unparse x))]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (T x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(primcall op rands) x]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (make-seq (E e0) (T e1))]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
(make-shortcut (T body) (T handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail" (unparse x))]))
* libaltcogen now passes 1.5
2007-02-11 17:34:13 -05:00
;(print-code x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(T x))
;;;
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
(define (do-spill sp* varvec)
(import conflict-helpers)
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (find/set-loc x)
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
(let f ([i 1] [conf (var-frm-conf x)])
(let ([fv (mkfvar i)])
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(cond
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
[(mem-frm? fv conf) (f (fxadd1 i) conf)]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[else
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
(for-each-var (var-var-conf x) varvec
(lambda (y)
* do-spill now removes spilled vars from neighbors of conflicting vars.
2007-06-06 02:24:32 -04:00
(set-var-var-conf! y
(rem-var x (var-var-conf y)))
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
(set-var-frm-conf! y
(add-frm fv (var-frm-conf y)))))
(set-var-loc! x fv)
(cons x fv)]))))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(map find/set-loc sp*))
;;;
(define (add-unspillables un* x)
(define who 'add-unspillables)
(define (mku)
(let ([u (unique-var 'u)])
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(set! un* (set-add u un*))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
u))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (S x k)
(cond
[(or (constant? x) (var? x) (symbol? x))
(k x)]
[else
(let ([u (mku)])
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(make-seq (E (make-asm-instr 'move u x)) (k u)))]))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (S* ls k)
(cond
[(null? ls) (k '())]
[else
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(S (car ls)
(lambda (a)
(S* (cdr ls)
(lambda (d)
(k (cons a d))))))]))
passing tests-1.5
2008-01-04 04:41:20 -05:00
(define (long-imm? x)
(struct-case x
[(constant n)
(cond
[(integer? n)
(not (<= (- (expt 2 31)) n (- (expt 2 31) 1)))]
[else #t])]
[else #f]))
Passing 548 tests in 64-bit mode.
2008-04-08 03:57:13 -04:00
(define (small-operand? x)
(case wordsize
[(4) (not (mem? x))]
[(8)
(struct-case x
[(constant n)
(cond
[(integer? n)
(<= (- (expt 2 31)) n (- (expt 2 31) 1))]
[else #f])]
[else (or (register? x) (var? x))])]
[else (error 'small-operand? "huh?")]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (mem? x)
(or (disp? x) (fvar? x)))
;;; unspillable effect
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (E x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(seq e0 e1) (make-seq (E e0) (E e1))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op a b)
(case op
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(logor logxor logand int+ int- int* move
move-byte load32
* optimized symbol calls using the symbol-function field. * added error checks for applying nonprocedures.
2007-02-25 21:29:28 -05:00
int-/overflow int+/overflow int*/overflow)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(cond
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
[(and (eq? op 'move) (eq? a b))
(make-primcall 'nop '())]
passing tests-1.5
2008-01-04 04:41:20 -05:00
[(and (= wordsize 8)
(not (eq? op 'move))
(long-imm? b))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u b))
(E (make-asm-instr op a u))))]
- Added primop for *.
2008-01-19 16:11:00 -05:00
[(and (memq op '(int* int*/overflow)) (mem? a))
(let ([u (mku)])
(make-seq
(make-seq
(E (make-asm-instr 'move u a))
(E (make-asm-instr op u b)))
(E (make-asm-instr 'move a u))))]
Passing 548 tests in 64-bit mode.
2008-04-08 03:57:13 -04:00
[(and (mem? a) (not (small-operand? b)))
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
(case op
[(load32)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'load32 u b))
(E (make-asm-instr 'move a u))))]
[else
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u b))
(E (make-asm-instr op a u))))])]
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
[(disp? a)
(let ([s0 (disp-s0 a)] [s1 (disp-s1 a)])
(cond
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(not (small-operand? s0))
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s0))
(E (make-asm-instr op (make-disp u s1) b))))]
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(not (small-operand? s1))
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s1))
(E (make-asm-instr op (make-disp s0 u) b))))]
Passing 548 tests in 64-bit mode.
2008-04-08 03:57:13 -04:00
[(small-operand? b) x]
[else
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u b))
(E (make-asm-instr op a u))))]))]
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
[(disp? b)
(let ([s0 (disp-s0 b)] [s1 (disp-s1 b)])
(cond
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(not (small-operand? s0))
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s0))
(E (make-asm-instr op a (make-disp u s1)))))]
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(not (small-operand? s1))
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s1))
(E (make-asm-instr op a (make-disp s0 u)))))]
[else x]))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[else x])]
* bytevector-ieee-double-ref/set! now work
2007-11-07 04:54:54 -05:00
[(bswap!)
(cond
[(mem? b)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u a))
(E (make-asm-instr 'bswap! u u))
(E (make-asm-instr 'move b u))))]
[else x])]
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[(cltd)
(unless (and (symbol? a) (symbol? b))
(error who "invalid args to cltd"))
x]
[(idiv)
(unless (symbol? a)
(error who "invalid arg to idiv"))
(cond
[(disp? b)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "invalid arg to idiv" b)]
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[else x])]
fxarithmetic-shift-left now detects overflows properly.
2008-03-18 00:49:24 -04:00
[(sll sra srl sll/overflow)
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
(unless (or (constant? b)
(eq? b ecx))
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "invalid shift" b))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
x]
Passing 709 tests in 64-bit mode
2008-04-12 15:06:55 -04:00
[(mset mset32 bset bset/c bset/h)
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(cond
Passing 548 tests in 64-bit mode.
2008-04-08 03:57:13 -04:00
[(not (small-operand? b))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(let ([u (mku)])
(make-seq
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
(E (make-asm-instr 'move u b))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(E (make-asm-instr op a u))))]
[else
(let ([s1 (disp-s0 a)] [s2 (disp-s1 a)])
(cond
[(and (mem? s1) (mem? s2))
(let ([u (mku)])
(make-seq
(make-seq
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(E (make-asm-instr 'move u s1))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(E (make-asm-instr 'int+ u s2)))
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
(make-asm-instr op
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(make-disp u (make-constant 0))
b)))]
[(mem? s1)
(let ([u (mku)])
(make-seq
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(E (make-asm-instr 'move u s1))
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
(E (make-asm-instr op (make-disp u s2) b))))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(mem? s2)
(let ([u (mku)])
(make-seq
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(E (make-asm-instr 'move u s2))
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
(E (make-asm-instr op (make-disp u s1) b))))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[else x]))])]
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:load-single fl:store-single)
* Added native support for $fl+, $fl-, $fl*, $fl/
2007-06-15 01:53:34 -04:00
(cond
[(mem? a)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u a))
(E (make-asm-instr op u b))))]
[else x])]
* Added bytevector-ieee-double-ref and bytevector-ieee-double-set! (which does not yet support big endianness)
2007-11-07 01:26:38 -05:00
[(fl:from-int fl:shuffle) x]
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[else (error who "invalid effect op" op)])]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(primcall op rands)
(case op
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(nop interrupt incr/zero? fl:single->double
fl:double->single) x]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid op in" (unparse x))])]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(ntcall) x]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
(let ([body (E body)])
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
(make-shortcut body (E handler)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" (unparse x))]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant) x]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))]
[(seq e0 e1) (make-seq (E e0) (P e1))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op a b)
(cond
* Added $fl=, $fl<, $fl>, $fl<=, $fl>= primops.
2007-06-15 05:19:28 -04:00
[(memq op '(fl:= fl:< fl:<= fl:> fl:>=))
(if (mem? a)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u a))
(make-asm-instr op u b)))
x)]
Now passing 682 tests in 64-bit mode.
2008-04-09 05:34:36 -04:00
[(and (not (mem? a)) (not (small-operand? a)))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u a))
(P (make-asm-instr op u b))))]
[(and (not (mem? b)) (not (small-operand? b)))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u b))
(P (make-asm-instr op a u))))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(and (mem? a) (mem? b))
(let ([u (mku)])
(make-seq
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(E (make-asm-instr 'move u b))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(make-asm-instr op a u)))]
[else x])]
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[(shortcut body handler)
(let ([body (P body)])
(make-shortcut body (P handler)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid pred" (unparse x))]))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (T x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(primcall op rands) x]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(make-conditional (P e0) (T e1) (T e2))]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(seq e0 e1) (make-seq (E e0) (T e1))]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
(make-shortcut (T body) (T handler))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail" (unparse x))]))
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(let ([x (T x)])
(values un* x)))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (color-program x)
(define who 'color-program)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
[(locals vars body)
(let ([varvec (car vars)] [sp* (cdr vars)])
* starting with IntegerSet
2007-03-10 16:47:13 -05:00
(let loop ([sp* (list->set sp*)] [un* (make-empty-set)] [body body])
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(let-values ([(un* body) (add-unspillables un* body)])
* removed the reg? argument to build-graph. Reg? was needed when build-graph was used for constructing both frame conflicts and register conflicts. Now, it's only used for register conflicts so reg? is no longer needed.
2007-06-05 23:10:28 -04:00
(let ([g (build-graph body)])
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(let-values ([(spills sp* env) (color-graph sp* un* g)])
(cond
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
[(null? spills) (substitute env body)]
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
[else
* removed one instance of build-graph which reduces compile time from 225 secs down to 17! Sweet!
2007-06-05 19:32:45 -04:00
(let* ([env (do-spill spills varvec)]
[body (substitute env body)])
* pre-spilling call-live variables works for the test cases now.
2007-02-17 18:09:03 -05:00
(loop sp* un* body))]))))))]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (color-by-chaitin x)
;;;
(define (ClambdaCase x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(clambda-case info body)
(make-clambda-case info (color-program body))]))
;;;
(define (Clambda x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
[(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) cp free* name)]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Program x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(codes code* body)
(make-codes (map Clambda code*) (color-program body))]))
;;;
(Program x))
#|chaitin module|#)
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
(define (compile-call-frame framesize livemask-vec multiarg-rp call-sequence)
(let ([L_CALL (label (gensym))]
[padding
(- call-instruction-size
(instruction-size call-sequence))])
(when (< padding 0)
(error 'compile-call-frame "call sequence too long" call-sequence))
(list 'seq
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
(if (or (= framesize 0) (= framesize 1))
'(seq)
`(subl ,(* (fxsub1 framesize) wordsize) ,fpr))
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
(jmp L_CALL)
`(byte-vector ,livemask-vec)
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
`(int ,(* framesize wordsize))
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
'(current-frame-offset)
multiarg-rp
`(byte-vector ,(make-vector padding 0))
L_CALL
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
call-sequence
(if (or (= framesize 0) (= framesize 1))
'(seq)
`(addl ,(* (fxsub1 framesize) wordsize) ,fpr)))))
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
* Altcogen works. Need to rethink how to code the conflict graphs.
2007-06-03 19:55:04 -04:00
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (flatten-codes x)
(define who 'flatten-codes)
;;;
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
(define (FVar i)
`(disp ,(* i (- wordsize)) ,fpr))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;;
(define (C x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(code-loc label) (label-address label)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(foreign-label L) `(foreign-label ,L)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(closure label free*)
(unless (null? free*) (error who "nonempty closure"))
`(obj ,x)]
[(object o)
`(obj ,o)]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[else
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(if (integer? x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
x
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "invalid constant C" x))]))
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
(define (BYTE x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[(constant x)
* Altcogen works. Need to rethink how to code the conflict graphs.
2007-06-03 19:55:04 -04:00
(unless (and (integer? x) (fx<= x 255) (fx<= -128 x))
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "invalid byte" x))
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
x]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid byte" x)]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (D x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(constant c) (C c)]
[else
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(if (symbol? x) x (error who "invalid D" x))]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
(define (R x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(constant c) (C c)]
[(fvar i) (FVar i)]
[(disp s0 s1)
(let ([s0 (D s0)] [s1 (D s1)])
`(disp ,s0 ,s1))]
[else
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(if (symbol? x) x (error who "invalid R" x))]))
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
(define (R/l x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
[(constant c) (C c)]
[(fvar i) (FVar i)]
[(disp s0 s1)
(let ([s0 (D s0)] [s1 (D s1)])
`(disp ,s0 ,s1))]
[else
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(if (symbol? x) (reg/l x) (error who "invalid R/l" x))]))
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
(define (reg/h x)
(cond
[(assq x '([%eax %ah] [%ebx %bh] [%ecx %ch] [%edx %dh]))
=> cadr]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid reg/h" x)]))
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
(define (reg/l x)
(cond
[(assq x '([%eax %al] [%ebx %bl] [%ecx %cl] [%edx %dl]))
=> cadr]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid reg/l" x)]))
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
(define (R/cl x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[(constant i)
(unless (fixnum? i)
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "invalid R/cl" x))
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
(fxlogand i 31)]
[else
(if (eq? x ecx)
'%cl
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
(error who "invalid R/cl" x))]))
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(define (interrupt? x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[(primcall op args) (eq? op 'interrupt)]
[else #f]))
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
;;; flatten effect
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (E x ac)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (E e0 (E e1 ac))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(cond
[(interrupt? e1)
(let ([L (or (exception-label)
(error who "no exception label"))])
(P e0 L #f (E e2 ac)))]
[(interrupt? e2)
(let ([L (or (exception-label)
(error who "no exception label"))])
(P e0 #f L (E e1 ac)))]
[else
(let ([lf (unique-label)] [le (unique-label)])
(P e0 #f lf
(E e1
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* `(jmp ,le) lf
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(E e2 (cons le ac))))))])]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(ntcall target value args mask size)
(let ([LCALL (unique-label)])
(define (rp-label value)
(if value
* Libraries can export modules now. * libaltcogen can now be loaded.
2007-06-02 03:21:05 -04:00
(label-address (sl-mv-error-rp-label))
(label-address (sl-mv-ignore-rp-label))))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(cond
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(string? target) ;; foreign call
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
(cons* ;`(subl ,(* (fxsub1 size) wordsize) ,fpr)
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
`(movl (foreign-label "ik_foreign_call") %ebx)
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
(compile-call-frame
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
size
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
mask
(rp-label value)
`(call %ebx))
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
;`(addl ,(* (fxsub1 size) wordsize) ,fpr)
* optimized symbol calls using the symbol-function field. * added error checks for applying nonprocedures.
2007-02-25 21:29:28 -05:00
ac)]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[target ;;; known call
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
(cons* ;`(subl ,(* (fxsub1 size) wordsize) ,fpr)
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
(compile-call-frame
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
size
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
mask
(rp-label value)
`(call (label ,target)))
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
;`(addl ,(* (fxsub1 size) wordsize) ,fpr)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
ac)]
[else
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
(cons* ;`(subl ,(* (fxsub1 size) wordsize) ,fpr)
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
(compile-call-frame
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
size
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
mask
(rp-label value)
`(call (disp ,(fx- disp-closure-code closure-tag)
,cp-register)))
Eliminated frame-pointer adjustment around calls if the adjustment is 0. Previously, you'd get addl 0, fpr <stuff> subl 0, fpr which are useless.
2008-01-10 03:26:18 -05:00
;`(addl ,(* (fxsub1 size) wordsize) ,fpr)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
ac)]))]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op d s)
(case op
[(logand) (cons `(andl ,(R s) ,(R d)) ac)]
[(int+) (cons `(addl ,(R s) ,(R d)) ac)]
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[(int*) (cons `(imull ,(R s) ,(R d)) ac)]
* split libcontrol into primitive libcontrol0 and extended libcontrol1.
2007-02-12 19:17:31 -05:00
[(int-) (cons `(subl ,(R s) ,(R d)) ac)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(logor) (cons `(orl ,(R s) ,(R d)) ac)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(logxor) (cons `(xorl ,(R s) ,(R d)) ac)]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(mset) (cons `(movl ,(R s) ,(R d)) ac)]
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
[(move)
(if (eq? d s)
ac
(cons `(movl ,(R s) ,(R d)) ac))]
* Added bref to assembler * Fixed bug in bytevector-s8-ref
2007-06-08 01:54:10 -04:00
[(move-byte)
(if (eq? d s)
ac
(cons `(movb ,(R/l s) ,(R/l d)) ac))]
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[(bset/c) (cons `(movb ,(BYTE s) ,(R d)) ac)]
[(bset/h) (cons `(movb ,(reg/h s) ,(R d)) ac)]
Passing 709 tests in 64-bit mode
2008-04-12 15:06:55 -04:00
[(bset) (cons `(movb ,(reg/l s) ,(R d)) ac)]
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
[(sll) (cons `(sall ,(R/cl s) ,(R d)) ac)]
[(sra) (cons `(sarl ,(R/cl s) ,(R d)) ac)]
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
[(srl) (cons `(shrl ,(R/cl s) ,(R d)) ac)]
* libnumeric can be compiled now with chaitin
2007-02-12 23:03:41 -05:00
[(idiv) (cons `(idivl ,(R s)) ac)]
[(cltd) (cons `(cltd) ac)]
* bytevector-ieee-double-ref/set! now work
2007-11-07 04:54:54 -05:00
[(bswap!)
(let ([s (R s)] [d (R d)])
(unless (eq? s d) (error who "invalid instr" x))
(cons `(bswap ,s) ac))]
570 tests in 64-bit mode
2008-04-09 03:05:19 -04:00
[(mset32) (cons `(mov32 ,(R s) ,(R d)) ac)]
[(load32) (cons `(mov32 ,(R s) ,(R d)) ac)]
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
[(int-/overflow)
(let ([L (or (exception-label)
(error who "no exception label"))])
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* `(subl ,(R s) ,(R d))
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
`(jo ,L)
ac))]
fxarithmetic-shift-left now detects overflows properly.
2008-03-18 00:49:24 -04:00
[(sll/overflow)
(let ([L (or (exception-label)
(error who "no exception label"))])
(cons* `(sall ,(R/cl s) ,(R d))
`(jo ,L)
ac))]
* optimized symbol calls using the symbol-function field. * added error checks for applying nonprocedures.
2007-02-25 21:29:28 -05:00
[(int*/overflow)
(let ([L (or (exception-label)
(error who "no exception label"))])
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* `(imull ,(R s) ,(R d))
* optimized symbol calls using the symbol-function field. * added error checks for applying nonprocedures.
2007-02-25 21:29:28 -05:00
`(jo ,L)
ac))]
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
[(int+/overflow)
(let ([L (or (exception-label)
(error who "no exception label"))])
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* `(addl ,(R s) ,(R d))
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
`(jo ,L)
ac))]
* Added native support for $fl+, $fl-, $fl*, $fl/
2007-06-15 01:53:34 -04:00
[(fl:store)
(cons `(movsd xmm0 ,(R (make-disp s d))) ac)]
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(fl:store-single)
(cons `(movss xmm0 ,(R (make-disp s d))) ac)]
* Added native support for $fl+, $fl-, $fl*, $fl/
2007-06-15 01:53:34 -04:00
[(fl:load)
(cons `(movsd ,(R (make-disp s d)) xmm0) ac)]
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(fl:load-single)
(cons `(movss ,(R (make-disp s d)) xmm0) ac)]
* $fixnum->flonum now works.
2007-06-18 07:29:39 -04:00
[(fl:from-int)
(cons `(cvtsi2sd ,(R s) xmm0) ac)]
* Added bytevector-ieee-double-ref and bytevector-ieee-double-set! (which does not yet support big endianness)
2007-11-07 01:26:38 -05:00
[(fl:shuffle)
(cons `(pshufb ,(R (make-disp s d)) xmm0) ac)]
* Added native support for $fl+, $fl-, $fl*, $fl/
2007-06-15 01:53:34 -04:00
[(fl:add!)
(cons `(addsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:sub!)
(cons `(subsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:mul!)
(cons `(mulsd ,(R (make-disp s d)) xmm0) ac)]
[(fl:div!)
(cons `(divsd ,(R (make-disp s d)) xmm0) ac)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid instr" x)])]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(primcall op rands)
(case op
[(nop) ac]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(interrupt)
(let ([l (or (exception-label)
(error who "no exception label"))])
(cons `(jmp ,l) ac))]
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
[(incr/zero?)
(let ([l (or (exception-label)
(error who "no exception label"))])
* Added cons*
2007-09-09 23:31:19 -04:00
(cons*
Added engine-handler parameter and a ($swap-engine-counter! <neg-fx>) to (ikarus system $interrupts).
2008-04-29 00:10:49 -04:00
`(addl ,(D (caddr rands)) ,(R (make-disp (car rands) (cadr rands))))
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
`(je ,l)
ac))]
* Added bytevector-ieee-single-native-ref and bytevector-ieee-single-native-set!
2007-11-08 22:22:24 -05:00
[(fl:double->single)
(cons '(cvtsd2ss xmm0 xmm0) ac)]
[(fl:single->double)
(cons '(cvtss2sd xmm0 xmm0) ac)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" (unparse x))])]
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[(shortcut body handler)
(let ([L (unique-interrupt-label)] [L2 (unique-label)])
(let ([hand (cons L (E handler `((jmp ,L2))))])
(let ([tc (exceptions-conc)])
(set-cdr! tc (append hand (cdr tc)))))
(parameterize ([exception-label L])
(E body (cons L2 ac))))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid effect" (unparse x))]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(define (unique-interrupt-label)
(label (gensym "ERROR")))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (unique-label)
(label (gensym)))
;;;
* Eliminates a jump-to-jump case in "flatten-code".
2007-11-21 05:31:01 -05:00
(define (constant=? x k)
(struct-case x
[(constant k0) (equal? k0 k)]
[else #f]))
;;;
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (P x lt lf ac)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[(constant c)
(if c
(if lt (cons `(jmp ,lt) ac) ac)
(if lf (cons `(jmp ,lf) ac) ac))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(seq e0 e1)
(E e0 (P e1 lt lf ac))]
[(conditional e0 e1 e2)
(cond
* Eliminates a jump-to-jump case in "flatten-code".
2007-11-21 05:31:01 -05:00
[(and (constant=? e1 #t) (constant=? e2 #f))
(P e0 lt lf ac)]
[(and (constant=? e1 #f) (constant=? e2 #t))
(P e0 lf lt ac)]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(and lt lf)
(let ([l (unique-label)])
(P e0 #f l
(P e1 lt lf
(cons l (P e2 lt lf ac)))))]
[lt
(let ([lf (unique-label)] [l (unique-label)])
(P e0 #f l
(P e1 lt lf
(cons l (P e2 lt #f (cons lf ac))))))]
[lf
(let ([lt (unique-label)] [l (unique-label)])
(P e0 #f l
(P e1 lt lf
(cons l (P e2 #f lf (cons lt ac))))))]
[else
(let ([lf (unique-label)] [l (unique-label)])
(P e0 #f l
(P e1 #f #f
(cons `(jmp ,lf)
(cons l (P e2 #f #f (cons lf ac)))))))])]
* fixed bug in assembler * assembler now handles orl imm, mem
2007-02-12 17:59:58 -05:00
[(asm-instr op a0 a1)
(let ()
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (notop x)
(cond
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(assq x '([= !=] [!= =] [< >=] [<= >] [> <=] [>= <]
* Added $fl=, $fl<, $fl>, $fl<=, $fl>= primops.
2007-06-15 05:19:28 -04:00
[u< u>=] [u<= u>] [u> u<=] [u>= u<]
* Added rationalize
2007-09-12 00:57:04 -04:00
[fl:= fl:o!=] [fl:!= fl:o=]
[fl:< fl:o>=] [fl:<= fl:o>]
[fl:> fl:o<=] [fl:>= fl:o<]
))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
=> cadr]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid notop" x)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (jmpname x)
(cond
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(assq x '([= je] [!= jne] [< jl] [<= jle] [> jg] [>= jge]
* Added $fl=, $fl<, $fl>, $fl<=, $fl>= primops.
2007-06-15 05:19:28 -04:00
[u< jb] [u<= jbe] [u> ja] [u>= jae]
[fl:= je] [fl:!= jne]
* Added rationalize
2007-09-12 00:57:04 -04:00
[fl:< jb] [fl:> ja] [fl:<= jbe] [fl:>= jae]
[fl:o= je] [fl:o!= jne]
[fl:o< jb] [fl:o> ja] [fl:o<= jbe] [fl:o>= jae]
))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
=> cadr]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid jmpname" x)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (revjmpname x)
(cond
* frame moves are not working as nicely as they should.
2007-02-19 18:21:35 -05:00
[(assq x '([= je] [!= jne] [< jg] [<= jge] [> jl] [>= jle]
* fixed bug in the graph construction that caused the operand of idivl not to be added to the live set.
2007-03-02 00:41:28 -05:00
[u< ja] [u<= jae] [u> jb] [u>= jbe]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
=> cadr]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid jmpname" x)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(define (cmp op a0 a1 lab ac)
(cond
* Added $fl=, $fl<, $fl>, $fl<=, $fl>= primops.
2007-06-15 05:19:28 -04:00
[(memq op '(fl:= fl:!= fl:< fl:<= fl:> fl:>=))
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* `(ucomisd ,(R (make-disp a0 a1)) xmm0)
* Added rationalize
2007-09-12 00:57:04 -04:00
`(,(jmpname op) ,lab)
;;; BOGUS!
ac)]
[(memq op '(fl:o= fl:o!= fl:o< fl:o<= fl:o> fl:o>=))
(cons* `(ucomisd ,(R (make-disp a0 a1)) xmm0)
`(jp ,lab)
* Added $fl=, $fl<, $fl>, $fl<=, $fl>= primops.
2007-06-15 05:19:28 -04:00
`(,(jmpname op) ,lab)
ac)]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(or (symbol? a0) (constant? a1))
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* `(cmpl ,(R a1) ,(R a0))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
`(,(jmpname op) ,lab)
ac)]
[(or (symbol? a1) (constant? a0))
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* `(cmpl ,(R a0) ,(R a1))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
`(,(revjmpname op) ,lab)
ac)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid cmpops" a0 a1)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
(cond
[(and lt lf)
(cmp op a0 a1 lt
(cons `(jmp ,lf) ac))]
[lt
(cmp op a0 a1 lt ac)]
[lf
(cmp (notop op) a0 a1 lf ac)]
[else ac]))]
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[(shortcut body handler)
(let ([L (unique-interrupt-label)] [lj (unique-label)])
(let ([ac (if (and lt lf) ac (cons lj ac))])
(let ([hand (cons L (P handler (or lt lj) (or lf lj) '()))])
(let ([tc (exceptions-conc)])
(set-cdr! tc (append hand (cdr tc)))))
(parameterize ([exception-label L])
(P body lt lf ac))))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid pred" x)]))
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
;;;
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(define (T x ac)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(seq e0 e1) (E e0 (T e1 ac))]
* altcompile now passes conditionals.
2007-02-11 17:23:13 -05:00
[(conditional e0 e1 e2)
(let ([L (unique-label)])
(P e0 #f L (T e1 (cons L (T e2 ac)))))]
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(primcall op rands)
(case op
[(return) (cons '(ret) ac)]
* altcompile now passes tests 1.3
2007-02-11 04:12:09 -05:00
[(indirect-jump)
(cons `(jmp (disp ,(fx- disp-closure-code closure-tag) ,cp-register))
ac)]
* passing 2.1
2007-02-11 18:52:10 -05:00
[(direct-jump)
(cons `(jmp (label ,(code-loc-label (car rands)))) ac)]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail" x)])]
* The shortcut form is now two parts: a body and a handler. The evaluation of the body can jump to the handler at any point during evaluation by means of using the interrupt primitive or by overflow.
2007-02-22 23:02:50 -05:00
[(shortcut body handler)
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(let ([L (unique-interrupt-label)])
(let ([hand (cons L (T handler '()))])
(let ([tc (exceptions-conc)])
(set-cdr! tc (append hand (cdr tc)))))
(parameterize ([exception-label L])
(T body ac)))]
* removed formatted errors from all source codes.
2007-10-25 14:32:26 -04:00
[else (error who "invalid tail" x)]))
* bug in collector causing dirty bits for code objects with younger reloc vectors to be unset incorrectly. The bug was in using || instead of | when computing the dirty pattern.
2007-02-22 21:58:38 -05:00
(define exception-label (make-parameter #f))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (handle-vararg fml-count ac)
(define CONTINUE_LABEL (unique-label))
(define DONE_LABEL (unique-label))
(define CONS_LABEL (unique-label))
(define LOOP_HEAD (unique-label))
(define L_CALL (unique-label))
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* (cmpl (int (argc-convention (fxsub1 fml-count))) eax)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(jl CONS_LABEL)
(movl (int nil) ebx)
(jmp DONE_LABEL)
CONS_LABEL
removed some hard-coded constants of pcb-offsets.
2008-01-01 23:07:41 -05:00
(movl (mem pcb-allocation-redline pcr) ebx)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(addl eax ebx)
(addl eax ebx)
(cmpl ebx apr)
(jle LOOP_HEAD)
; overflow
(addl eax esp) ; advance esp to cover args
(pushl cpr) ; push current cp
(pushl eax) ; push argc
(negl eax) ; make argc positive
(addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size
(pushl eax) ; push frame size
(addl eax eax) ; double the number of args
(movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg
(movl (int (argc-convention 1)) eax) ; setup argc
(movl (primref-loc 'do-vararg-overflow) cpr) ; load handler
Abstracted the construction of call frames and automated the padding process. The compiler no longer has hardcoded null bytes inserted into the code streams.
2008-01-02 07:01:45 -05:00
(compile-call-frame 0 '#() '(int 0) (indirect-cpr-call))
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(popl eax) ; pop framesize and drop it
(popl eax) ; reload argc
(popl cpr) ; reload cp
(subl eax fpr) ; readjust fp
LOOP_HEAD
(movl (int nil) ebx)
CONTINUE_LABEL
(movl ebx (mem disp-cdr apr))
(movl (mem fpr eax) ebx)
(movl ebx (mem disp-car apr))
(movl apr ebx)
(addl (int pair-tag) ebx)
(addl (int pair-size) apr)
(addl (int (fxsll 1 fx-shift)) eax)
(cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax)
(jle CONTINUE_LABEL)
DONE_LABEL
(movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr))
ac))
;;;
* before attempting to use chaitin to compile the system.
2007-02-11 21:42:01 -05:00
(define (properize args proper ac)
(cond
[proper ac]
[else
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(handle-vararg (length (cdr args)) ac)]))
* before attempting to use chaitin to compile the system.
2007-02-11 21:42:01 -05:00
;;;
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(define (ClambdaCase x ac)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(clambda-case info body)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case info
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(case-info L args proper)
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(let ([lothers (unique-label)])
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* `(cmpl ,(argc-convention
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(if proper
(length (cdr args))
(length (cddr args))))
,argc-register)
(cond
[proper `(jne ,lothers)]
[(> (argc-convention 0) (argc-convention 1))
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
`(jg ,lothers)]
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
[else
* The $apply macro and all the appcall forms were removed from the compiler after realizing that I was stupid. ($appcall rator rand*) was just (jmpcal SL_apply rator rand*)
2007-02-14 15:50:34 -05:00
`(jl ,lothers)])
* passes tests, but fails to compile psyntax.
2007-02-12 13:58:04 -05:00
(properize args proper
(cons (label L)
(T body (cons lothers ac))))))])]))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Clambda x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
Added an optimization that removes self-references from fix-bound closures.
2007-11-21 04:00:10 -05:00
[(clambda L case* cp free* name)
* Added cons*
2007-09-09 23:31:19 -04:00
(cons* (length free*)
* compiler and fasl-write and fasl-read now understand code annotations
2007-10-10 04:41:11 -04:00
`(name ,name)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(label L)
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(let ([ac (list '(nop))])
(parameterize ([exceptions-conc ac])
(let f ([case* case*])
(cond
[(null? case*)
* Libraries can export modules now. * libaltcogen can now be loaded.
2007-06-02 03:21:05 -04:00
(cons `(jmp (label ,(sl-invalid-args-label))) ac)]
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
[else
(ClambdaCase (car case*) (f (cdr case*)))])))))]))
;;;
(define exceptions-conc (make-parameter #f))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
;;;
(define (Program x)
* removed all "record"-related procedures, replacing them by equivalent "struct" procedures.
2007-10-12 02:59:27 -04:00
(struct-case x
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
[(codes code* body)
* Added cons*
2007-09-09 23:31:19 -04:00
(cons (cons* 0
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(label (gensym))
* added a $set-symbol-function! primitive.
2007-02-24 15:42:57 -05:00
(let ([ac (list '(nop))])
(parameterize ([exceptions-conc ac])
(T body ac))))
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(map Clambda code*))]))
* chaitin can now compile the system.
2007-02-17 19:22:14 -05:00
;;; (print-code x)
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(Program x))
(define (print-code x)
* libaltcogen now passes 1.5
2007-02-11 17:34:13 -05:00
(parameterize ([print-gensym '#t])
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
(pretty-print (unparse x))))
(define (alt-cogen x)
* removed old one-pass compiler. chaitin is now the default backend
2007-06-05 19:57:48 -04:00
(define (time-it name proc)
(proc))
* removed more junk.
2007-06-05 20:11:12 -04:00
(let* ([x (introduce-primcalls x)]
[x (eliminate-fix x)]
* Interrupts now work, again
2007-09-05 01:47:57 -04:00
[x (insert-engine-checks x)]
* Stack overflow is reinstated. fibc and other call/cc intensive benchmarks now work.
2007-07-13 06:54:25 -04:00
[x (insert-stack-overflow-check x)]
* Switched order of two compiler passes: specify-representation and insert-stack-overflow-check. This will make it easier to remove unnecessary stack checks and to add some that we *may* be missing. * Added a $stack-overflow-check primitive that takes care of checking and calling ikrt_stack_overflow if we did detect an overflow.
2007-11-05 15:30:42 -05:00
[x (specify-representation x)]
* removed more junk.
2007-06-05 20:11:12 -04:00
[x (impose-calling-convention/evaluation-order x)]
[x (time-it "frame" (lambda () (assign-frame-sizes x)))]
[x (time-it "register" (lambda () (color-by-chaitin x)))]
[ls (flatten-codes x)])
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
ls))
* adding some asm tests in asm-tests.ss
2007-02-13 05:08:48 -05:00
* libaltcogen can now compile a simple expression :-)
2007-02-10 18:51:12 -05:00
#|module alt-cogen|#)