* Can load altcogen.
This commit is contained in:
Abdulaziz Ghuloum
parent
6279bc7c47
commit
a5dbb8f45d
|
|
@ -1,327 +0,0 @@
|
|||
#!/usr/bin/env ikarus -b ikarus.boot --script
|
||||
|
||||
;;; 9.1: * starting with libnumerics
|
||||
;;; 9.0: * graph marks for both reader and writer
|
||||
;;; * circularity detection during read
|
||||
;;; 8.1: * using chez-style io ports
|
||||
;;; 6.9: * creating a *system* environment
|
||||
;;; 6.8: * creating a core-primitive form in the expander
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
|
||||
|
||||
(define macros
|
||||
'(|#primitive| lambda case-lambda set! quote begin define if letrec
|
||||
foreign-call
|
||||
quasiquote unquote unquote-splicing
|
||||
define-syntax identifier-syntax let-syntax letrec-syntax
|
||||
fluid-let-syntax alias meta eval-when with-implicit with-syntax
|
||||
type-descriptor
|
||||
syntax-case syntax-rules module $module import $import import-only
|
||||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda trace-define
|
||||
rec
|
||||
time))
|
||||
|
||||
|
||||
|
||||
(define public-primitives
|
||||
'(
|
||||
|
||||
null? pair? char? fixnum? symbol? gensym? string? vector? list?
|
||||
boolean? procedure? not eof-object eof-object? bwp-object?
|
||||
void fx= fx< fx<= fx> fx>= fxzero? fx+ fx- fx* fxadd1 fxsub1
|
||||
fxquotient fxremainder fxmodulo fxsll fxsra fxlognot fxlogor
|
||||
fxlogand fxlogxor integer->char char->integer char=? char<?
|
||||
char<=? char>? char>=? cons car cdr set-car! set-cdr! caar
|
||||
cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
|
||||
cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr list list*
|
||||
make-list length list-ref append make-vector vector-ref
|
||||
vector-set! vector-length vector vector->list list->vector
|
||||
make-string string-ref string-set! string-length string
|
||||
string->list list->string uuid string-append substring string=?
|
||||
string<? string<=? string>? string>=? remprop putprop getprop
|
||||
property-list $$apply apply map for-each andmap ormap memq memv assq
|
||||
assv assoc eq? eqv? equal? reverse string->symbol symbol->string
|
||||
top-level-value set-top-level-value! top-level-bound?
|
||||
gensym gensym-count gensym-prefix print-gensym
|
||||
gensym->unique-string call-with-values values make-parameter
|
||||
dynamic-wind display write print-graph fasl-write printf fprintf format
|
||||
print-error read-token read comment-handler error warning exit call/cc
|
||||
error-handler eval current-eval compile alt-compile compile-file
|
||||
alt-compile-file
|
||||
new-cafe load system expand sc-expand current-expand expand-mode
|
||||
environment? interaction-environment identifier?
|
||||
free-identifier=? bound-identifier=? literal-identifier=?
|
||||
datum->syntax-object syntax-object->datum syntax-error
|
||||
syntax->list generate-temporaries record? record-set! record-ref
|
||||
record-length record-type-descriptor make-record-type
|
||||
record-printer record-name record-field-accessor
|
||||
record-field-mutator record-predicate record-constructor
|
||||
record-type-name record-type-symbol record-type-field-names
|
||||
hash-table? make-hash-table get-hash-table put-hash-table!
|
||||
assembler-output $make-environment
|
||||
command-line-arguments port? input-port? output-port?
|
||||
make-input-port make-output-port make-input/output-port
|
||||
port-handler port-input-buffer port-input-index port-input-size
|
||||
port-output-buffer port-output-index port-output-size
|
||||
set-port-input-index! set-port-input-size!
|
||||
set-port-output-index! set-port-output-size! port-name
|
||||
input-port-name output-port-name write-char read-char
|
||||
unread-char peek-char newline reset-input-port!
|
||||
flush-output-port close-input-port close-output-port
|
||||
console-input-port current-input-port standard-output-port
|
||||
standard-error-port console-output-port current-output-port
|
||||
open-output-file open-input-file open-output-string
|
||||
with-output-to-string
|
||||
get-output-string with-output-to-file call-with-output-file
|
||||
open-input-string
|
||||
with-input-from-file call-with-input-file date-string
|
||||
file-exists? delete-file + - add1 sub1 * / expt
|
||||
quotient+remainder quotient remainder modulo number? positive?
|
||||
negative? zero? number->string logand = < > <= >=
|
||||
last-pair
|
||||
make-guardian weak-cons collect
|
||||
interrupt-handler
|
||||
time-it
|
||||
posix-fork fork waitpid env environ
|
||||
pretty-print
|
||||
even? odd? member char-whitespace? char-alphabetic?
|
||||
char-downcase max min complex? real? rational?
|
||||
exact? inexact? integer?
|
||||
string->number exact->inexact
|
||||
|
||||
flonum? flonum->string string->flonum bignum?
|
||||
sin cos atan sqrt
|
||||
))
|
||||
|
||||
(define system-primitives
|
||||
'(
|
||||
$primitive-call/cc
|
||||
$closure-code immediate? $unbound-object? $forward-ptr?
|
||||
pointer-value primitive-ref primitive-set! $fx= $fx< $fx<= $fx>
|
||||
$fx>= $fxzero? $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
|
||||
$fxremainder $fxmodulo $fxsll $fxsra $fxlognot $fxlogor
|
||||
$fxlogand $fxlogxor $fixnum->char $char->fixnum $char= $char<
|
||||
$char<= $char> $char>= $car $cdr $set-car! $set-cdr!
|
||||
$make-vector $vector-ref $vector-set! $vector-length
|
||||
$make-string $string-ref $string-set! $string-length $string
|
||||
$symbol-string $symbol-unique-string $symbol-value
|
||||
$set-symbol-string! $set-symbol-unique-string!
|
||||
$set-symbol-value! $make-symbol $set-symbol-plist!
|
||||
$symbol-plist $sc-put-cte $record? $record/rtd? $record-set!
|
||||
$record-ref $record-rtd $make-record $record $base-rtd $code?
|
||||
$code-reloc-vector $code-freevars $code-size $code-ref
|
||||
$code-set! $code->closure list*->code* make-code code?
|
||||
set-code-reloc-vector! code-reloc-vector code-freevars
|
||||
code-size code-ref code-set! $frame->continuation $fp-at-base
|
||||
$current-frame $arg-list $seal-frame-and-call
|
||||
$make-call-with-values-procedure $make-values-procedure
|
||||
do-overflow $make-tcbucket $tcbucket-next $tcbucket-key
|
||||
$tcbucket-val $set-tcbucket-next! $set-tcbucket-val!
|
||||
$set-tcbucket-tconc!
|
||||
call/cf
|
||||
trace-symbol! untrace-symbol! make-traced-procedure
|
||||
fixnum->string
|
||||
$interrupted? $unset-interrupted! $do-event
|
||||
$fasl-read
|
||||
;;; TODO: must open-code
|
||||
|
||||
$make-port/input $make-port/output $make-port/both
|
||||
$make-input-port $make-output-port $make-input/output-port
|
||||
$port-handler $port-input-buffer $port-input-index
|
||||
$port-input-size $port-output-buffer $port-output-index
|
||||
$port-output-size $set-port-input-index! $set-port-input-size!
|
||||
$set-port-output-index! $set-port-output-size!
|
||||
|
||||
;;; better open-code
|
||||
|
||||
$write-char $read-char $peek-char $unread-char
|
||||
|
||||
;;; never open-code
|
||||
|
||||
$reset-input-port! $close-input-port $close-output-port
|
||||
$flush-output-port *standard-output-port* *standard-error-port*
|
||||
*current-output-port* *standard-input-port* *current-input-port*
|
||||
|
||||
;;;
|
||||
compiler-giveup-tally
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (whack-system-env setenv?)
|
||||
(define add-prim
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))])
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* (cons 'core-primitive x)))))
|
||||
(define add-macro
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))]
|
||||
[e (getprop x '*sc-expander*)])
|
||||
(when e
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* e)))))
|
||||
(define (foo)
|
||||
(eval
|
||||
`(begin
|
||||
(define-syntax compile-time-date-string
|
||||
(lambda (x)
|
||||
#'(quote ,(date-string))))
|
||||
(define-syntax public-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,public-primitives)))
|
||||
(define-syntax system-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,system-primitives)))
|
||||
(define-syntax macros
|
||||
(lambda (x)
|
||||
#'(quote ,macros))))))
|
||||
(set! system-env ($make-environment '|#system| #t))
|
||||
(for-each add-macro macros)
|
||||
(for-each add-prim public-primitives)
|
||||
(for-each add-prim system-primitives)
|
||||
(if setenv?
|
||||
(parameterize ([interaction-environment system-env])
|
||||
(foo))
|
||||
(foo)))
|
||||
|
||||
|
||||
|
||||
(when (eq? "" "")
|
||||
(error #f "SEVERELY OUT OF DATE!\n")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #f)
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.9.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #t)
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.9.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-8.1.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(whack-system-env #t)
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers.ss" "libhandlers.fasl" p0 chaitin]
|
||||
["libcontrol0.ss" "libcontrol0.fasl" p0 chaitin]
|
||||
["libcontrol1.ss" "libcontrol1.fasl" p0 chaitin]
|
||||
["libcollect.ss" "libcollect.fasl" p0 chaitin]
|
||||
["librecord.ss" "librecord.fasl" p0 chaitin]
|
||||
["libcxr.ss" "libcxr.fasl" p0 chaitin]
|
||||
["libnumerics.ss" "libnumerics.fasl" p0 chaitin]
|
||||
["libguardians.ss" "libguardians.fasl" p0 chaitin]
|
||||
["libcore.ss" "libcore.fasl" p0 chaitin]
|
||||
["libchezio.ss" "libchezio.fasl" p0 chaitin]
|
||||
["libhash.ss" "libhash.fasl" p0 chaitin]
|
||||
["libwriter.ss" "libwriter.fasl" p0 chaitin]
|
||||
["libtokenizer.ss" "libtokenizer.fasl" p0 chaitin]
|
||||
["libassembler.ss" "libassembler.fasl" p0 chaitin]
|
||||
["libintelasm.ss" "libintelasm.fasl" p0 chaitin]
|
||||
["libfasl.ss" "libfasl.fasl" p0 chaitin]
|
||||
["libtrace.ss" "libtrace.fasl" p0 chaitin]
|
||||
["libcompile.ss" "libcompile.fasl" p1 chaitin]
|
||||
["psyntax-7.1.ss" "psyntax.fasl" p0 chaitin]
|
||||
["libpp.ss" "libpp.fasl" p0 chaitin]
|
||||
["libcafe.ss" "libcafe.fasl" p0 chaitin]
|
||||
["libposix.ss" "libposix.fasl" p0 chaitin]
|
||||
["libtimers.ss" "libtimers.fasl" p0 chaitin]
|
||||
["libtoplevel.ss" "libtoplevel.fasl" p0 chaitin]
|
||||
))
|
||||
|
||||
|
||||
(define (read-file ifile)
|
||||
(with-input-from-file ifile
|
||||
(lambda ()
|
||||
(let f ()
|
||||
(let ([x (read)])
|
||||
(if (eof-object? x)
|
||||
'()
|
||||
(cons x (f))))))))
|
||||
|
||||
(define (expand-file ifile)
|
||||
(map sc-expand (read-file ifile)))
|
||||
|
||||
(define (compile-library ifile ofile which-compile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(let ([proc
|
||||
(case which-compile
|
||||
[(onepass) compile-file]
|
||||
[(chaitin) alt-compile-file]
|
||||
[else (error 'compile-library "unknown compile ~s"
|
||||
which-compile)])])
|
||||
(printf "compiling ~a ... \n" ifile)
|
||||
(proc ifile ofile 'replace))))
|
||||
|
||||
|
||||
|
||||
;(let ()
|
||||
; (define (compile-all who)
|
||||
; (for-each
|
||||
; (lambda (x)
|
||||
; (when (eq? who (caddr x))
|
||||
; (compile-library (car x) (cadr x) (cadddr x))))
|
||||
; scheme-library-files))
|
||||
; (define (time x) x)
|
||||
; (fork
|
||||
; (lambda (pid)
|
||||
; (time (compile-all 'p1))
|
||||
; (unless (fxzero? (waitpid pid))
|
||||
; (exit -1)))
|
||||
; (lambda ()
|
||||
; (time (compile-all 'p0))
|
||||
; (exit))))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x) (cadddr x)))
|
||||
scheme-library-files)
|
||||
|
||||
(define (join s ls)
|
||||
(cond
|
||||
[(null? ls) ""]
|
||||
[else
|
||||
(let ([str (open-output-string)])
|
||||
(let f ([a (car ls)] [d (cdr ls)])
|
||||
(cond
|
||||
[(null? d)
|
||||
(display a str)
|
||||
(get-output-string str)]
|
||||
[else
|
||||
(display a str)
|
||||
(display s str)
|
||||
(f (car d) (cdr d))])))]))
|
||||
|
||||
|
||||
(system
|
||||
(format "cat ~a > ikarus.boot"
|
||||
(join " " (map cadr scheme-library-files))))
|
||||
|
||||
(printf "Happy Happy Joy Joy!\n")
|
||||
;(#%compiler-giveup-tally)
|
||||
; vim:syntax=scheme
|
||||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -5318,6 +5318,12 @@
|
|||
|
||||
(define assembler-output (make-parameter #f))
|
||||
|
||||
|
||||
(define eval-core
|
||||
(lambda (x) ((compile-core-expr x))))
|
||||
|
||||
(include "libaltcogen.ss")
|
||||
|
||||
(define current-primitive-locations
|
||||
(let ([plocs (lambda (x) #f)])
|
||||
(case-lambda
|
||||
|
|
@ -5329,12 +5335,6 @@
|
|||
(refresh-cached-labels!))
|
||||
(error 'current-primitive-locations "~s is not a procedure" p))])))
|
||||
|
||||
(define eval-core
|
||||
(lambda (x) ((compile-core-expr x))))
|
||||
|
||||
(include "libaltcogen.ss")
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -336,6 +336,8 @@
|
|||
(CODE c (ModRM 2 /d a1 (IMM32 a0 ac)))]
|
||||
[(and (imm8? a1) (reg? a0))
|
||||
(CODE c (ModRM 1 /d a0 (IMM8 a1 ac)))]
|
||||
[(and (imm? a1) (reg? a0))
|
||||
(CODE c (ModRM 2 /d a0 (IMM32 a1 ac)))]
|
||||
[(and (reg? a0) (reg? a1))
|
||||
(CODE c (ModRM 1 /d '/4 (SIB 0 a0 a1 (IMM8 0 ac))))]
|
||||
[else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]
|
||||
|
|
|
|||
|
|
@ -1244,6 +1244,73 @@
|
|||
#|ListyGraphs|#)
|
||||
|
||||
|
||||
(module IntegerGraphs
|
||||
(empty-graph add-edge! empty-graph? print-graph node-neighbors
|
||||
delete-node!)
|
||||
(import IntegerSet)
|
||||
;;;
|
||||
(define-record graph (ls))
|
||||
;;;
|
||||
(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)))
|
||||
|
||||
(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
|
||||
(list* (cons x (single y))
|
||||
(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)]))
|
||||
|
||||
(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|#)
|
||||
|
||||
(module (assign-frame-sizes)
|
||||
;;; assign-frame-sizes module
|
||||
(define indent (make-parameter 0))
|
||||
|
|
@ -1997,6 +2064,8 @@
|
|||
(module (color-by-chaitin)
|
||||
(import ListySet)
|
||||
(import ListyGraphs)
|
||||
;(import IntegerSet)
|
||||
;(import IntegerGraphs)
|
||||
;;;
|
||||
(define (set-for-each f s)
|
||||
(for-each f (set->list s)))
|
||||
|
|
@ -2931,14 +3000,6 @@
|
|||
[ls (flatten-codes x)]
|
||||
;[foo (printf "8")]
|
||||
)
|
||||
(when #f
|
||||
(parameterize ([gensym-prefix "L"]
|
||||
[print-gensym #f])
|
||||
(for-each
|
||||
(lambda (ls)
|
||||
(newline)
|
||||
(for-each (lambda (x) (printf " ~s\n" x)) ls))
|
||||
ls)))
|
||||
ls))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -406,6 +406,7 @@
|
|||
[gensym->unique-string i symbols]
|
||||
[symbol-bound? i symbols]
|
||||
[symbol-value i symbols]
|
||||
[top-level-value i symbols]
|
||||
[set-symbol-value! i symbols]
|
||||
[make-guardian i]
|
||||
[make-input-port i]
|
||||
|
|
@ -520,7 +521,6 @@
|
|||
[system i]
|
||||
|
||||
[installed-libraries i]
|
||||
[compile-core-expr-to-port $boot]
|
||||
[current-primitive-locations $boot]
|
||||
[boot-library-expand $boot]
|
||||
[eval-core $boot]
|
||||
|
|
@ -853,9 +853,16 @@
|
|||
[(assq x locs) => cdr]
|
||||
[else
|
||||
(error 'bootstrap "no location for ~s" x)])))
|
||||
(let ([p (open-output-file "ikarus.boot" 'replace)])
|
||||
(let ([p (open-output-file "ikarus.boot.new" 'replace)]
|
||||
[idx 0])
|
||||
(for-each
|
||||
(lambda (x) (compile-core-expr-to-port x p))
|
||||
(lambda (x)
|
||||
(set! idx (+ idx 1))
|
||||
(cond
|
||||
[(memv idx '(1))
|
||||
(alt-compile-core-expr-to-port x p)]
|
||||
[else
|
||||
(compile-core-expr-to-port x p)]))
|
||||
core*)
|
||||
(close-output-port p)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -70,6 +70,11 @@
|
|||
|
||||
(section ;;; simple objects section
|
||||
|
||||
(define-primop base-rtd safe
|
||||
[(V) (prm 'mref pcr (K 44))]
|
||||
[(P) (K #t)]
|
||||
[(E) (prm 'nop)])
|
||||
|
||||
(define-primop void safe
|
||||
[(V) (K void-object)]
|
||||
[(P) (K #t)]
|
||||
|
|
@ -494,6 +499,7 @@
|
|||
; (prm 'mref x (K (- disp-symbol-error-function symbol-tag))))
|
||||
(dirty-vector-set x))])
|
||||
|
||||
|
||||
(define-primop top-level-value safe
|
||||
[(V x)
|
||||
(record-case x
|
||||
|
|
@ -668,6 +674,48 @@
|
|||
[(P x) (sec-tag-test (T x) vector-mask vector-tag bignum-mask bignum-tag)]
|
||||
[(E x) (nop)])
|
||||
|
||||
(define-primop $bignum-positive? unsafe
|
||||
[(P x)
|
||||
(prm '= (prm 'logand
|
||||
(prm 'mref (T x) (K (- vector-tag)))
|
||||
(K bignum-sign-mask))
|
||||
(K 0))]
|
||||
[(E x) (nop)])
|
||||
|
||||
(define-primop $bignum-byte-ref unsafe
|
||||
[(V s i)
|
||||
(record-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(prm 'sll
|
||||
(prm 'logand
|
||||
(prm 'mref (T s)
|
||||
(K (+ i (- disp-bignum-data record-tag))))
|
||||
(K 255))
|
||||
(K fx-shift))]
|
||||
[else
|
||||
(prm 'sll
|
||||
(prm 'srl ;;; FIXME: bref
|
||||
(prm 'mref (T s)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
;;; ENDIANNESS DEPENDENCY
|
||||
(K (- disp-bignum-data
|
||||
(- wordsize 1)
|
||||
record-tag))))
|
||||
(K (* (- wordsize 1) 8)))
|
||||
(K fx-shift))])]
|
||||
[(P s i) (K #t)]
|
||||
[(E s i) (nop)])
|
||||
|
||||
(define-primop $bignum-size unsafe
|
||||
[(V x)
|
||||
(prm 'sll
|
||||
(prm 'sra
|
||||
(prm 'mref (T x) (K (- record-tag)))
|
||||
(K bignum-length-shift))
|
||||
(K (* 2 fx-shift)))])
|
||||
|
||||
/section)
|
||||
|
||||
(section ;;; flonums
|
||||
|
|
@ -678,6 +726,31 @@
|
|||
|
||||
/section)
|
||||
|
||||
(section ;;; ratnums
|
||||
|
||||
(define-primop ratnum? safe
|
||||
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f ratnum-tag)]
|
||||
[(E x) (nop)])
|
||||
|
||||
(define-primop $make-ratnum unsafe
|
||||
[(V num den)
|
||||
(with-tmp ([x (prm 'alloc (K (align ratnum-size)) (K vector-tag))])
|
||||
(prm 'mset x (K (- vector-tag)) (K ratnum-tag))
|
||||
(prm 'mset x (K (- disp-ratnum-num vector-tag)) (T num))
|
||||
(prm 'mset x (K (- disp-ratnum-den vector-tag)) (T den))
|
||||
x)]
|
||||
[(P str) (K #t)]
|
||||
[(E str) (nop)])
|
||||
|
||||
|
||||
(define-primop $ratnum-n unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- vector-tag disp-ratnum-num)))])
|
||||
|
||||
(define-primop $ratnum-d unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- vector-tag disp-ratnum-den)))])
|
||||
|
||||
/section)
|
||||
|
||||
(section ;;; generic arithmetic
|
||||
|
||||
(define (non-fixnum? x)
|
||||
|
|
@ -981,6 +1054,170 @@
|
|||
|
||||
/section)
|
||||
|
||||
(section ;;; bytevectors
|
||||
|
||||
(define-primop bytevector? safe
|
||||
[(P x) (tag-test (T x) bytevector-mask bytevector-tag)]
|
||||
[(E x) (nop)])
|
||||
|
||||
(define-primop $make-bytevector unsafe
|
||||
[(V n)
|
||||
(record-case n
|
||||
[(constant n)
|
||||
(unless (fixnum? n) (interrupt))
|
||||
(with-tmp ([s (prm 'alloc
|
||||
(K (align (+ n 1 disp-bytevector-data)))
|
||||
(K bytevector-tag))])
|
||||
(prm 'mset s
|
||||
(K (- disp-bytevector-length bytevector-tag))
|
||||
(K (* n fixnum-scale)))
|
||||
(prm 'bset/c s
|
||||
(K (+ n (- disp-bytevector-data bytevector-tag)))
|
||||
(K 0))
|
||||
s)]
|
||||
[else
|
||||
(with-tmp ([s (prm 'alloc
|
||||
(align-code
|
||||
(prm 'sra (T n) (K fixnum-shift))
|
||||
(+ disp-bytevector-data 1))
|
||||
(K bytevector-tag))])
|
||||
(prm 'mset s
|
||||
(K (- disp-bytevector-length bytevector-tag))
|
||||
(T n))
|
||||
(prm 'bset/c s
|
||||
(prm 'int+
|
||||
(prm 'sra (T n) (K fixnum-shift))
|
||||
(K (- disp-bytevector-data bytevector-tag)))
|
||||
(K 0))
|
||||
s)])]
|
||||
[(P n) (K #t)]
|
||||
[(E n) (nop)])
|
||||
|
||||
(define-primop $bytevector-length unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-bytevector-length bytevector-tag)))]
|
||||
[(P x) (K #t)]
|
||||
[(E x) (nop)])
|
||||
|
||||
(define-primop $bytevector-u8-ref unsafe
|
||||
[(V s i)
|
||||
(record-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(prm 'sll
|
||||
(prm 'logand
|
||||
(prm 'mref (T s)
|
||||
(K (+ i (- disp-bytevector-data bytevector-tag))))
|
||||
(K 255))
|
||||
(K fx-shift))]
|
||||
[else
|
||||
(prm 'sll
|
||||
(prm 'srl ;;; FIXME: bref
|
||||
(prm 'mref (T s)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
;;; ENDIANNESS DEPENDENCY
|
||||
(K (- disp-bytevector-data
|
||||
(- wordsize 1)
|
||||
bytevector-tag))))
|
||||
(K (* (- wordsize 1) 8)))
|
||||
(K fx-shift))])]
|
||||
[(P s i) (K #t)]
|
||||
[(E s i) (nop)])
|
||||
|
||||
(define-primop $bytevector-s8-ref unsafe
|
||||
[(V s i)
|
||||
(record-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(prm 'srl
|
||||
(prm 'sll
|
||||
(prm 'logand
|
||||
(prm 'mref (T s)
|
||||
(K (+ i (- disp-bytevector-data bytevector-tag))))
|
||||
(K 255))
|
||||
(K (- (* wordsize 8) 8)))
|
||||
(K (- (* wordsize 8) (+ 8 fx-shift))))]
|
||||
[else
|
||||
(prm 'srl
|
||||
(prm 'sll
|
||||
(prm 'srl ;;; FIXME: bref
|
||||
(prm 'mref (T s)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
;;; ENDIANNESS DEPENDENCY
|
||||
(K (- disp-bytevector-data
|
||||
(- wordsize 1)
|
||||
bytevector-tag))))
|
||||
(K (* (- wordsize 1) 8)))
|
||||
(K fx-shift))
|
||||
(K (- (* wordsize 8) (+ 8 fx-shift))))])]
|
||||
[(P s i) (K #t)]
|
||||
[(E s i) (nop)])
|
||||
|
||||
#;
|
||||
(define (assert-fixnum x)
|
||||
(record-case x
|
||||
[(constant i)
|
||||
(if (fixnum? i) (nop) (interrupt))]
|
||||
[else (interrupt-unless (cogen-pred-fixnum? x))]))
|
||||
#;
|
||||
(define (assert-string x)
|
||||
(record-case x
|
||||
[(constant s) (if (string? s) (nop) (interrupt))]
|
||||
[else (interrupt-unless (cogen-pred-string? x))]))
|
||||
#;
|
||||
(define-primop string-ref safe
|
||||
[(V s i)
|
||||
(seq*
|
||||
(assert-fixnum i)
|
||||
(assert-string s)
|
||||
(interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s)))
|
||||
(cogen-value-$string-ref s i))]
|
||||
[(P s i)
|
||||
(seq*
|
||||
(assert-fixnum i)
|
||||
(assert-string s)
|
||||
(interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s)))
|
||||
(K #t))]
|
||||
[(E s i)
|
||||
(seq*
|
||||
(assert-fixnum i)
|
||||
(assert-string s)
|
||||
(interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s))))])
|
||||
|
||||
(define-primop $bytevector-set! unsafe
|
||||
[(E x i c)
|
||||
(record-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(record-case c
|
||||
[(constant c)
|
||||
(unless (fixnum? c) (interrupt))
|
||||
(prm 'bset/c (T x)
|
||||
(K (+ i (- disp-bytevector-data bytevector-tag)))
|
||||
(K c))]
|
||||
[else
|
||||
(prm 'bset/h (T x)
|
||||
(K (+ i (- disp-bytevector-data bytevector-tag)))
|
||||
(prm 'sll (T c) (K (- 8 fx-shift))))])]
|
||||
[else
|
||||
(record-case c
|
||||
[(constant c)
|
||||
(unless (fixnum? c) (interrupt))
|
||||
(prm 'bset/c (T x)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(K (- disp-bytevector-data bytevector-tag)))
|
||||
(K c))]
|
||||
[else
|
||||
(prm 'bset/h (T x)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(K (- disp-bytevector-data bytevector-tag)))
|
||||
(prm 'sll (T c) (K (- 8 fx-shift))))])])])
|
||||
|
||||
/section)
|
||||
|
||||
(section ;;; strings
|
||||
|
||||
(define-primop string? safe
|
||||
|
|
@ -993,29 +1230,19 @@
|
|||
[(constant n)
|
||||
(unless (fixnum? n) (interrupt))
|
||||
(with-tmp ([s (prm 'alloc
|
||||
(K (align (+ n 1 disp-string-data)))
|
||||
(K (align (+ (* n wordsize) disp-string-data)))
|
||||
(K string-tag))])
|
||||
(prm 'mset s
|
||||
(K (- disp-string-length string-tag))
|
||||
(K (* n fixnum-scale)))
|
||||
(prm 'bset/c s
|
||||
(K (+ n (- disp-string-data string-tag)))
|
||||
(K 0))
|
||||
s)]
|
||||
[else
|
||||
(with-tmp ([s (prm 'alloc
|
||||
(align-code
|
||||
(prm 'sra (T n) (K fixnum-shift))
|
||||
(+ disp-string-data 1))
|
||||
(align-code (T n) disp-string-data)
|
||||
(K string-tag))])
|
||||
(prm 'mset s
|
||||
(K (- disp-string-length string-tag))
|
||||
(T n))
|
||||
(prm 'bset/c s
|
||||
(prm 'int+
|
||||
(prm 'sra (T n) (K fixnum-shift))
|
||||
(K (- disp-string-data string-tag)))
|
||||
(K 0))
|
||||
s)])]
|
||||
[(P n) (K #t)]
|
||||
[(E n) (nop)])
|
||||
|
|
@ -1031,28 +1258,13 @@
|
|||
(record-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(prm 'logor
|
||||
(prm 'sll
|
||||
(prm 'logand
|
||||
(prm 'mref (T s)
|
||||
(K (+ i (- disp-string-data string-tag))))
|
||||
(K 255))
|
||||
(K char-shift))
|
||||
(K char-tag))]
|
||||
(prm 'mref (T s)
|
||||
(K (+ (* i fixnum-scale)
|
||||
(- disp-string-data string-tag))))]
|
||||
[else
|
||||
(prm 'logor
|
||||
(prm 'sll
|
||||
(prm 'srl ;;; FIXME: bref
|
||||
(prm 'mref (T s)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
;;; ENDIANNESS DEPENDENCY
|
||||
(K (- disp-string-data
|
||||
(- wordsize 1)
|
||||
string-tag))))
|
||||
(K (* (- wordsize 1) 8)))
|
||||
(K char-shift))
|
||||
(K char-tag))])]
|
||||
(prm 'mref (T s)
|
||||
(prm 'int+ (T i)
|
||||
(K (- disp-string-data string-tag))))])]
|
||||
[(P s i) (K #t)]
|
||||
[(E s i) (nop)])
|
||||
|
||||
|
|
@ -1092,33 +1304,13 @@
|
|||
(record-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(record-case c
|
||||
[(constant c)
|
||||
(unless (char? c) (interrupt))
|
||||
(prm 'bset/c (T x)
|
||||
(K (+ i (- disp-string-data string-tag)))
|
||||
(K (char->integer c)))]
|
||||
[else
|
||||
(unless (= char-shift 8) (error 'cogen-$string-set! "BUG"))
|
||||
(prm 'bset/h (T x)
|
||||
(K (+ i (- disp-string-data string-tag)))
|
||||
(T c))])]
|
||||
(prm 'mset (T x)
|
||||
(K (+ (* i fixnum-scale) (- disp-string-data string-tag)))
|
||||
(T c))]
|
||||
[else
|
||||
(record-case c
|
||||
[(constant c)
|
||||
(unless (char? c) (interrupt))
|
||||
(prm 'bset/c (T x)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(K (- disp-string-data string-tag)))
|
||||
(K (char->integer c)))]
|
||||
[else
|
||||
(unless (= char-shift 8) (error 'cogen-$string-set! "BUG"))
|
||||
(prm 'bset/h (T x)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(K (- disp-string-data string-tag)))
|
||||
(T c))])])])
|
||||
(prm 'mset (T x)
|
||||
(prm 'int+ (T i) (K (- disp-string-data string-tag)))
|
||||
(T c))])])
|
||||
|
||||
/section)
|
||||
|
||||
|
|
@ -1291,7 +1483,7 @@
|
|||
|
||||
(section ;;; codes
|
||||
|
||||
(define-primop $code? unsafe
|
||||
(define-primop code? unsafe
|
||||
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f code-tag)])
|
||||
|
||||
(define-primop $closure-code unsafe
|
||||
|
|
|
|||
|
|
@ -415,7 +415,7 @@
|
|||
(lambda (sym)
|
||||
(record-symbol-call! sym)
|
||||
(prm 'mref (T (K sym))
|
||||
(K (- disp-symbol-record-proc symbol-ptag))))]
|
||||
(K (- disp-symbol-record-value symbol-ptag))))]
|
||||
[else (nonproc x)])]
|
||||
[(primref op) (V x)]
|
||||
[else (nonproc x)]))
|
||||
|
|
@ -468,7 +468,7 @@
|
|||
[cmpl ,closure-tag ,cp-register]
|
||||
[jne (label ,L1)]
|
||||
[movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) ,cp-register]
|
||||
[movl ,cp-register (disp ,(- disp-symbol-record-proc symbol-ptag) (obj ,symbol))]
|
||||
[movl ,cp-register (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol))]
|
||||
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
|
||||
[label ,L1]
|
||||
[movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) %eax]
|
||||
|
|
@ -507,7 +507,8 @@
|
|||
(let ([code* (map Clambda code*)]
|
||||
[body (V body)])
|
||||
(make-codes code*
|
||||
(make-seq (error-codes) body)))]
|
||||
;(make-seq (error-codes) body)
|
||||
body))]
|
||||
[else (error 'specify-rep "invalid program ~s" x)]))
|
||||
|
||||
(define (specify-representation x)
|
||||
|
|
|
|||
Loading…
Reference in New Issue