20071025 16:27:34 04:00



;;; Ikarus Scheme  A compiler for R6RS Scheme.

20080129 00:34:34 05:00



;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum

20071025 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/>.





20070309 14:01:17 05:00







(definesyntax section




(syntaxrules (/section)




[(section e* ... /section) (begin e* ...)]))








(section ;;; helpers





20070302 02:47:36 05:00



(define (prm op . arg*)




(makeprimcall op arg*))








(define (nop) (makeprimcall 'nop '()))








(define (K x) (makeconstant x))












(define (tagtest x mask tag)




(if mask




(prm '= (prm 'logand x (K mask)) (K tag))




(prm '= x (K tag))))








(define (sectagtest x pmask ptag smask stag)




(makeconditional




(tagtest x pmask ptag)




(tagtest (prm 'mref x (K ( ptag))) smask stag)




(makeconstant #f)))








(define (dirtyvectorset address)

20080407 12:32:55 04:00



(define shiftbits 2)

20080719 17:41:06 04:00



(prm 'mset32




(prm 'mref pcr (K pcbdirtyvector))




(prm 'sll (prm 'srl address (K pageshift)) (K shiftbits))

20070302 02:47:36 05:00



(K dirtyword)))








(define (smartdirtyvectorset addr what)

20071012 02:59:27 04:00



(structcase what

20070302 02:47:36 05:00



[(constant t)

20080718 04:35:13 04:00



(if (or (fx? t) (immediate? t))

20070302 02:47:36 05:00



(prm 'nop)




(dirtyvectorset addr))]

20080707 02:48:16 04:00



[(known x t)




(cond




[(eq? (T:immediate? t) 'yes)




(recordoptimization 'smartdirtyvec t)




(nop)]




[else (smartdirtyvectorset addr x)])]

20070302 02:47:36 05:00



[else (dirtyvectorset addr)]))





20071201 22:32:19 05:00



(define (slowmemassign v x i)

20070302 02:47:36 05:00



(withtmp ([t (prm 'int+ x (K i))])




(makeseq




(prm 'mset t (K 0) (T v))




(dirtyvectorset t))))





20071201 22:32:19 05:00



(define (memassign v x i)




(structcase v

20070302 02:47:36 05:00



[(constant t)

20080718 04:35:13 04:00



(if (or (fx? t) (immediate? t))

20071201 22:32:19 05:00



(prm 'mset x (K i) (T v))




(slowmemassign v x i))]

20080707 02:48:16 04:00



[(known expr t)




(cond




[(eq? (T:immediate? t) 'yes)




(recordoptimization 'memassign v)




(prm 'mset x (K i) (T expr))]




[else (slowmemassign expr x i)])]

20071201 22:32:19 05:00



[else (slowmemassign v x i)]))

20070302 02:47:36 05:00







(define (aligncode unknownamt knownamt)




(prm 'sll




(prm 'sra




(prm 'int+ unknownamt




(K (+ knownamt (sub1 objectalignment))))




(K alignshift))




(K alignshift)))

20070309 14:01:17 05:00



/section)

20070302 02:47:36 05:00







(section ;;; simple objects section





20070602 21:55:40 04:00



(defineprimop basertd safe

20080101 23:07:41 05:00



[(V) (prm 'mref pcr (K pcbbasertd))]

20070602 21:55:40 04:00



[(P) (K #t)]




[(E) (prm 'nop)])





20070302 02:47:36 05:00



(defineprimop void safe




[(V) (K voidobject)]




[(P) (K #t)]




[(E) (prm 'nop)])








(defineprimop nop unsafe




[(E) (prm 'nop)])








(defineprimop neq? unsafe




[(P x y) (prm '!= (T x) (T y))]




[(E x y) (nop)])








(defineprimop eq? safe




[(P x y) (prm '= (T x) (T y))]




[(E x y) (nop)])





20080628 05:25:44 04:00



(define (equableconstant? x)




(structcase x




[(constant xv) (equable? xv)]

20080707 02:48:16 04:00



[(known x t) (equableconstant? x)]

20080628 05:25:44 04:00



[else #f]))








(defineprimop eqv? safe




[(P x y)




(if (or (equableconstant? x)




(equableconstant? y))




(prm '= (T x) (T y))




(interrupt))]




[(E x y) (nop)])





20070302 02:47:36 05:00



(defineprimop null? safe




[(P x) (prm '= (T x) (K nil))]




[(E x) (nop)])





20070303 23:17:04 05:00



(defineprimop not safe




[(P x) (prm '= (T x) (K boolf))]




[(E x) (nop)])





20070302 02:47:36 05:00



(defineprimop eofobject safe




[(V) (K eof)]




[(P) (K #t)]




[(E) (nop)])








(defineprimop eofobject? safe




[(P x) (prm '= (T x) (K eof))]




[(E x) (nop)])








(defineprimop $unboundobject? unsafe




[(P x) (prm '= (T x) (K unbound))]




[(E x) (nop)])








(defineprimop immediate? safe




[(P x)




(makeconditional

20080103 04:42:10 05:00



(tagtest (T x) fxmask fxtag)

20070302 02:47:36 05:00



(makeconstant #t)




(tagtest (T x) 7 7))]




[(E x) (nop)])








(defineprimop boolean? safe

20080707 02:48:16 04:00



[(P x)




(tagtest (T x) boolmask booltag)]

20070302 02:47:36 05:00



[(E x) (nop)])








(defineprimop bwpobject? safe




[(P x) (prm '= (T x) (K bwpobject))]




[(E x) (nop)])








(defineprimop $forwardptr? unsafe




[(P x) (prm '= (T x) (K 1))]




[(E x) (nop)])








(defineprimop pointervalue unsafe

20070830 19:40:01 04:00



[(V x) (prm 'logand




(prm 'srl (T x) (K 1))

20080103 04:42:10 05:00



(K (* 1 fxscale)))]

20070302 02:47:36 05:00



[(P x) (K #t)]




[(E x) (nop)])








(defineprimop $arglist unsafe

20080101 23:07:41 05:00



[(V) (prm 'mref pcr (K pcbarglist))]

20070302 02:47:36 05:00



[(P) (K #t)]




[(E) (nop)])





20070830 22:02:25 04:00



(defineprimop $collectkey unsafe

20080101 23:07:41 05:00



[(V) (prm 'mref pcr (K pcbcollectkey))]




[(E x) (prm 'mset pcr (K pcbcollectkey) (T x))])

20070830 22:02:25 04:00




20070303 23:17:04 05:00



(defineprimop $memq safe




[(P x ls)

20071012 02:59:27 04:00



(structcase ls

20070303 23:17:04 05:00



[(constant ls)




(cond




[(not (list? ls)) (interrupt)]




[else




(withtmp ([x (T x)])




(let f ([ls ls])




(cond




[(null? ls) (K #f)]




[(null? (cdr ls)) (prm '= x (T (K (car ls))))]




[else




(makeconditional




(prm '= x (T (K (car ls))))




(K #t)




(f (cdr ls)))])))])]

20080707 02:48:16 04:00



[(known expr t)




(cogenpred$memq x expr)]

20070303 23:17:04 05:00



[else (interrupt)])]




[(V x ls)

20071012 02:59:27 04:00



(structcase ls

20070303 23:17:04 05:00



[(constant ls)




(cond




[(not (list? ls)) (interrupt)]




[else




(withtmp ([x (T x)])




(let f ([ls ls])




(cond




[(null? ls) (K boolf)]




[else




(makeconditional




(prm '= x (T (K (car ls))))




(T (K ls))




(f (cdr ls)))])))])]

20080707 02:48:16 04:00



[(known expr t)




(cogenvalue$memq x expr)]

20070303 23:17:04 05:00



[else (interrupt)])]




[(E x ls) (nop)])





20080628 05:25:44 04:00



(defineprimop memq safe




[(P x ls) (cogenpred$memq x ls)]




[(V x ls) (cogenvalue$memq x ls)]




[(E x ls)




(structcase ls




[(constant ls)




(cond




[(list? ls) (nop)]




[else (interrupt)])]

20081012 01:15:20 04:00



[(known expr t)




(cogeneffectmemq x expr)]

20080628 05:25:44 04:00



[else (interrupt)])])








(define (equable? x)

20080718 04:35:13 04:00



(or (fx? x) (not (number? x))))

20080628 05:25:44 04:00







(defineprimop memv safe




[(V x ls)




(structcase ls




[(constant lsv)




(cond




[(and (list? lsv) (andmap equable? lsv))




(cogenvalue$memq x ls)]




[else (interrupt)])]

20081012 01:15:20 04:00



[(known expr t)




(cogenvaluememv x expr)]

20080628 05:25:44 04:00



[else (interrupt)])]




[(P x ls)




(structcase ls




[(constant lsv)




(cond




[(and (list? lsv) (andmap equable? lsv))




(cogenpred$memq x ls)]




[else (interrupt)])]

20081012 01:15:20 04:00



[(known expr t)




(cogenpredmemv x expr)]

20080628 05:25:44 04:00



[else (interrupt)])]




[(E x ls)




(structcase ls




[(constant lsv)




(cond




[(list? lsv) (nop)]




[else (interrupt)])]

20081012 01:15:20 04:00



[(known expr t)




(cogeneffectmemv x expr)]

20080628 05:25:44 04:00



[else (interrupt)])])

20070303 23:17:04 05:00




20070302 02:47:36 05:00



/section)








(section ;;; pairs








(defineprimop pair? safe

20080707 02:48:16 04:00



[(P x)




(tagtest (T x) pairmask pairtag)]

20070302 02:47:36 05:00



[(E x) (nop)])








(defineprimop cons safe




[(V a d)




(withtmp ([t (prm 'alloc (K pairsize) (K pairtag))])




(prm 'mset t (K ( dispcar pairtag)) (T a))




(prm 'mset t (K ( dispcdr pairtag)) (T d))




t)]




[(P a d) (K #t)]




[(E a d) (prm 'nop)])








(defineprimop $car unsafe




[(V x) (prm 'mref (T x) (K ( dispcar pairtag)))]




[(E x) (nop)])








(defineprimop $cdr unsafe




[(V x) (prm 'mref (T x) (K ( dispcdr pairtag)))]




[(E x) (nop)])








(defineprimop $setcar! unsafe




[(E x v)




(withtmp ([x (T x)])




(prm 'mset x (K ( dispcar pairtag)) (T v))




(smartdirtyvectorset x v))])








(defineprimop $setcdr! unsafe




[(E x v)




(withtmp ([x (T x)])




(prm 'mset x (K ( dispcdr pairtag)) (T v))




(smartdirtyvectorset x v))])





20080707 02:48:16 04:00



(define (assertpair x)




(structcase x




[(known x t)




(case (T:pair? t)




[(yes) (recordoptimization 'assertpair x) (nop)]




[(no) (interrupt)]




[else (assertpair x)])]




[else




(interruptunless (tagtest x pairmask pairtag))]))





20070302 02:47:36 05:00



(defineprimop car safe




[(V x)

20080707 02:48:16 04:00



(withtmp ([x (T x)])




(assertpair x)




(prm 'mref x (K ( dispcar pairtag))))]




[(E x) (assertpair (T x))])

20070302 02:47:36 05:00







(defineprimop cdr safe




[(V x)

20080707 02:48:16 04:00



(withtmp ([x (T x)])




(assertpair x)




(prm 'mref x (K ( dispcdr pairtag))))]




[(E x) (assertpair (T x))])

20070302 02:47:36 05:00







(defineprimop setcar! safe




[(E x v)




(withtmp ([x (T x)])

20080707 02:48:16 04:00



(assertpair x)

20070302 02:47:36 05:00



(prm 'mset x (K ( dispcar pairtag)) (T v))




(smartdirtyvectorset x v))])








(defineprimop setcdr! safe




[(E x v)




(withtmp ([x (T x)])

20080707 02:48:16 04:00



(assertpair x)

20070302 02:47:36 05:00



(prm 'mset x (K ( dispcdr pairtag)) (T v))




(smartdirtyvectorset x v))])





20080118 22:44:40 05:00







(define (expandcxr val ls)




(cond




[(null? ls) (T val)]




[else




(withtmp ([x (expandcxr val (cdr ls))])

20080707 02:48:16 04:00



(assertpair x)

20080118 22:44:40 05:00



(prm 'mref x




(case (car ls)




[(a) (K ( dispcar pairtag))]




[else (K ( dispcdr pairtag))])))]))








(defineprimop caar safe [(V x) (expandcxr x '(a a))])




(defineprimop cadr safe [(V x) (expandcxr x '(a d))])




(defineprimop cdar safe [(V x) (expandcxr x '(d a))])




(defineprimop cddr safe [(V x) (expandcxr x '(d d))])




(defineprimop caaar safe [(V x) (expandcxr x '(a a a))])




(defineprimop caadr safe [(V x) (expandcxr x '(a a d))])




(defineprimop cadar safe [(V x) (expandcxr x '(a d a))])




(defineprimop caddr safe [(V x) (expandcxr x '(a d d))])




(defineprimop cdaar safe [(V x) (expandcxr x '(d a a))])




(defineprimop cdadr safe [(V x) (expandcxr x '(d a d))])




(defineprimop cddar safe [(V x) (expandcxr x '(d d a))])




(defineprimop cdddr safe [(V x) (expandcxr x '(d d d))])




;(defineprimop caaaar safe [(V x) (expandcxr x '(a a a a))])




;(defineprimop caaadr safe [(V x) (expandcxr x '(a a a d))])




;(defineprimop caadar safe [(V x) (expandcxr x '(a a d a))])




;(defineprimop caaddr safe [(V x) (expandcxr x '(a a d d))])




;(defineprimop cadaar safe [(V x) (expandcxr x '(a d a a))])




;(defineprimop cadadr safe [(V x) (expandcxr x '(a d a d))])




;(defineprimop caddar safe [(V x) (expandcxr x '(a d d a))])




(defineprimop cadddr safe [(V x) (expandcxr x '(a d d d))])




;(defineprimop cdaaar safe [(V x) (expandcxr x '(d a a a))])




;(defineprimop cdaadr safe [(V x) (expandcxr x '(d a a d))])




;(defineprimop cdadar safe [(V x) (expandcxr x '(d a d a))])




;(defineprimop cdaddr safe [(V x) (expandcxr x '(d a d d))])




;(defineprimop cddaar safe [(V x) (expandcxr x '(d d a a))])




;(defineprimop cddadr safe [(V x) (expandcxr x '(d d a d))])




;(defineprimop cdddar safe [(V x) (expandcxr x '(d d d a))])




;(defineprimop cddddr safe [(V x) (expandcxr x '(d d d d))])









20070302 02:47:36 05:00



(defineprimop list safe




[(V) (K nil)]




[(V . arg*)




(let ([n (length arg*)] [t* (map T arg*)])




(withtmp ([v (prm 'alloc (K (align (* n pairsize))) (K pairtag))])




(prm 'mset v (K ( dispcar pairtag)) (car t*))




(prm 'mset v




(K ( (+ dispcdr (* (sub1 n) pairsize)) pairtag))




(K nil))




(let f ([t* (cdr t*)] [i pairsize])




(cond




[(null? t*) v]




[else




(withtmp ([tmp (prm 'int+ v (K i))])




(prm 'mset tmp (K ( dispcar pairtag)) (car t*))




(prm 'mset tmp (K (+ dispcdr ( pairsize) ( pairtag))) tmp)




(f (cdr t*) (+ i pairsize)))]))))]




[(P . arg*) (K #t)]




[(E . arg*) (nop)])





20070909 23:31:19 04:00



(defineprimop cons* safe




[(V) (interrupt)]




[(V x) (T x)]




[(V a . a*)




(let ([t* (map T a*)] [n (length a*)])




(withtmp ([v (prm 'alloc (K (* n pairsize)) (K pairtag))])




(prm 'mset v (K ( dispcar pairtag)) (T a))




(let f ([t* t*] [i pairsize])




(cond




[(null? (cdr t*))




(seq* (prm 'mset v (K ( i dispcdr pairtag)) (car t*)) v)]




[else




(withtmp ([tmp (prm 'int+ v (K i))])




(prm 'mset tmp (K ( dispcar pairtag)) (car t*))




(prm 'mset tmp (K ( ( dispcdr pairtag) pairsize)) tmp)




(f (cdr t*) (+ i pairsize)))]))))]




[(P) (interrupt)]




[(P x) (P x)]




[(P a . a*) (K #t)]




[(E) (interrupt)]




[(E . a*) (nop)])





20070302 02:47:36 05:00















/section)








(section ;;; vectors

20070602 03:21:05 04:00



(section ;;; helpers




(define (vectorrangecheck x idx)

20080707 02:48:16 04:00



(define (checknonvector x idx)




(define (checkfx idx)




(seq*




(interruptunless (tagtest (T x) vectormask vectortag))




(withtmp ([len (cogenvalue$vectorlength x)])




(interruptunless (prm 'u< (T idx) len))




(interruptunlessfixnum len))))




(define (check? idx)




(seq*




(interruptunless (tagtest (T x) vectormask vectortag))




(withtmp ([len (cogenvalue$vectorlength x)])




(interruptunless (prm 'u< (T idx) len))




(withtmp ([t (prm 'logor len (T idx))])




(interruptunlessfixnum t)))))




(structcase idx




[(constant i)

20080718 04:35:13 04:00



(if (and (fx? i) (>= i 0))

20080707 02:48:16 04:00



(checkfx idx)




(check? idx))]




[(known idx idxt)




(case (T:fixnum? idxt)




[(yes) (checkfx idx)]




[(maybe) (vectorrangecheck x idx)]




[else




(printf "vector check with mismatch index tag ~s" idxt)




(vectorrangecheck x idx)])]




[else (check? idx)]))




(define (checkvector x idx)




(define (checkfx idx)

20070602 03:21:05 04:00



(withtmp ([len (cogenvalue$vectorlength x)])

20080707 02:48:16 04:00



(interruptunless (prm 'u< (T idx) len))))




(define (check? idx)




(seq*




(interruptunlessfixnum (T idx))




(withtmp ([len (cogenvalue$vectorlength x)])




(interruptunless (prm 'u< (T idx) len)))))




(structcase idx




[(constant i)

20080718 04:35:13 04:00



(if (and (fx? i) (>= i 0))

20080707 02:48:16 04:00



(checkfx idx)

20090103 19:48:23 05:00



(interrupt))]

20080707 02:48:16 04:00



[(known idx idxt)




(case (T:fixnum? idxt)




[(yes) (checkfx idx)]




[(no) (interrupt)]




[else (checkvector x idx)])]




[else (check? idx)]))




(structcase x




[(known x t)




(case (T:vector? t)




[(yes) (recordoptimization 'checkvector x) (checkvector x idx)]




[(no) (interrupt)]




[else (checknonvector x idx)])]




[else (checknonvector x idx)]))

20070602 03:21:05 04:00



/section)

20070302 02:47:36 05:00







(defineprimop vector? unsafe

20080103 04:42:10 05:00



[(P x) (sectagtest (T x) vectormask vectortag fxmask fxtag)]

20070302 02:47:36 05:00



[(E x) (nop)])








(defineprimop $makevector unsafe




[(V len)

20071012 02:59:27 04:00



(structcase len

20070302 02:47:36 05:00



[(constant i)

20080718 04:35:13 04:00



(if (and (fx? i) #f)

20080707 02:48:16 04:00



(interrupt)




(withtmp ([v (prm 'alloc




(K (align (+ (* i wordsize) dispvectordata)))




(K vectortag))])




(prm 'mset v




(K ( dispvectorlength vectortag))




(K (* i fxscale)))




v))]




[(known expr t)




(cogenvalue$makevector expr)]

20070302 02:47:36 05:00



[else




(withtmp ([alen (aligncode (T len) dispvectordata)])




(withtmp ([v (prm 'alloc alen (K vectortag))])

20080707 02:48:16 04:00



(prm 'mset v (K ( dispvectorlength vectortag)) (T len))




v))])]

20070302 02:47:36 05:00



[(P len) (K #t)]




[(E len) (nop)])





20071201 05:38:09 05:00



(defineprimop makevector safe




[(V len)

20080707 02:48:16 04:00



(withtmp ([x (makeforcall "ikrt_make_vector1" (list (T len)))])

20071201 05:38:09 05:00



(interruptwhen (prm '= x (K 0)))




x)])





20070302 02:47:36 05:00



(defineprimop $vectorref unsafe




[(V x i)




(or

20071012 02:59:27 04:00



(structcase i

20070302 02:47:36 05:00



[(constant i)

20080718 04:35:13 04:00



(and (fx? i)

20070302 02:47:36 05:00



(fx>= i 0)




(prm 'mref (T x)




(K (+ (* i wordsize) ( dispvectordata vectortag)))))]

20080707 02:48:16 04:00



[(known i t)




(cogenvalue$vectorref x i)]

20070302 02:47:36 05:00



[else #f])

20080623 01:10:05 04:00



(prm 'mref (T x)




(prm 'int+ (T i) (K ( dispvectordata vectortag)))))]




[(E x i) (nop)])

20070302 02:47:36 05:00







(defineprimop $vectorlength unsafe




[(V x) (prm 'mref (T x) (K ( dispvectorlength vectortag)))]




[(E x) (prm 'nop)]




[(P x) (K #t)])








(defineprimop vectorlength safe




[(V x)

20080707 02:48:16 04:00



(structcase x




[(known x t)




(case (T:vector? t)




[(yes) (recordoptimization 'vectorlength x) (cogenvalue$vectorlength x)]




[(no) (interrupt)]




[else (cogenvaluevectorlength x)])]




[else




(seq*




(interruptunless (tagtest (T x) vectormask vectortag))




(withtmp ([t (cogenvalue$vectorlength x)])




(interruptunlessfixnum t)




t))])]

20070302 02:47:36 05:00



[(E x)

20080707 02:48:16 04:00



(structcase x




[(known x t)




(case (T:vector? t)




[(yes) (recordoptimization 'vectorlength x) (nop)]




[(no) (interrupt)]




[else (cogeneffectvectorlength x)])]




[else




(seq*




(interruptunless (tagtest (T x) vectormask vectortag))




(withtmp ([t (cogenvalue$vectorlength x)])




(interruptunlessfixnum t)))])]

20070302 02:47:36 05:00



[(P x)




(seq* (cogeneffectvectorlength x) (K #t))])








(defineprimop vectorref safe




[(V x i)




(seq*




(vectorrangecheck x i)




(cogenvalue$vectorref x i))]




[(E x i)




(vectorrangecheck x i)])












(defineprimop $vectorset! unsafe




[(E x i v)

20071012 02:59:27 04:00



(structcase i

20070302 02:47:36 05:00



[(constant i)

20090103 19:48:23 05:00



(if (not (fx? i))




(interrupt)




(memassign v (T x)




(+ (* i wordsize)




( dispvectordata vectortag))))]

20080707 02:48:16 04:00



[(known i t)




(cogeneffect$vectorset! x i v)]

20070302 02:47:36 05:00



[else




(memassign v




(prm 'int+ (T x) (T i))




( dispvectordata vectortag))])])





20070303 23:17:04 05:00



(defineprimop vectorset! safe

20070302 02:47:36 05:00



[(E x i v)




(seq*




(vectorrangecheck x i)




(cogeneffect$vectorset! x i v))])








(defineprimop vector safe




[(V . arg*)




(withtmp ([v (prm 'alloc




(K (align (+ dispvectordata




(* (length arg*) wordsize))))




(K vectortag))])




(seq*




(prm 'mset v (K ( dispvectorlength vectortag))




(K (* (length arg*) wordsize)))




(let f ([t* (map T arg*)]




[i ( dispvectordata vectortag)])




(cond




[(null? t*) v]




[else




(makeseq




(prm 'mset v (K i) (car t*))




(f (cdr t*) (+ i wordsize)))]))))]




[(E . arg*) (prm 'nop)]




[(P . arg*) (K #t)])








/section)








(section ;;; closures








(defineprimop procedure? safe




[(P x) (tagtest (T x) closuremask closuretag)])








(defineprimop $cpref unsafe




[(V x i)

20071012 02:59:27 04:00



(structcase i

20070302 02:47:36 05:00



[(constant i)

20080718 04:35:13 04:00



(unless (fx? i) (interrupt))

20070302 02:47:36 05:00



(prm 'mref (T x)




(K (+ ( dispclosuredata closuretag)




(* i wordsize))))]

20081012 01:15:20 04:00



[(known expr t)




(cogenvalue$cpref x expr)]

20070302 02:47:36 05:00



[else (interrupt)])])








/section)








(section ;;; symbols








(defineprimop symbol? safe

20070603 19:55:04 04:00



[(P x)




(sectagtest (T x) vectormask vectortag #f symbolrecordtag)]

20070302 02:47:36 05:00



[(E x) (nop)])








(defineprimop $makesymbol unsafe




[(V str)

20070602 03:21:05 04:00



(withtmp ([x (prm 'alloc (K (align symbolrecordsize)) (K symbolptag))])




(prm 'mset x (K ( symbolptag)) (K symbolrecordtag))




(prm 'mset x (K ( dispsymbolrecordstring symbolptag)) (T str))




(prm 'mset x (K ( dispsymbolrecordustring symbolptag)) (K 0))




(prm 'mset x (K ( dispsymbolrecordvalue symbolptag)) (K unbound))




(prm 'mset x (K ( dispsymbolrecordproc symbolptag)) (K unbound))




(prm 'mset x (K ( dispsymbolrecordplist symbolptag)) (K nil))

20070302 02:47:36 05:00



x)]




[(P str) (K #t)]




[(E str) (nop)])








(defineprimop $symbolstring unsafe

20070602 03:21:05 04:00



[(V x) (prm 'mref (T x) (K ( dispsymbolrecordstring symbolptag)))]

20070302 02:47:36 05:00



[(E x) (nop)])








(defineprimop $setsymbolstring! unsafe

20070602 03:21:05 04:00



[(E x v) (memassign v (T x) ( dispsymbolrecordstring symbolptag))])

20070302 02:47:36 05:00







(defineprimop $symboluniquestring unsafe

20070602 03:21:05 04:00



[(V x) (prm 'mref (T x) (K ( dispsymbolrecordustring symbolptag)))]

20070302 02:47:36 05:00



[(E x) (nop)])








(defineprimop $setsymboluniquestring! unsafe

20070602 03:21:05 04:00



[(E x v) (memassign v (T x) ( dispsymbolrecordustring symbolptag))])

20070302 02:47:36 05:00







(defineprimop $symbolplist unsafe

20070602 03:21:05 04:00



[(V x) (prm 'mref (T x) (K ( dispsymbolrecordplist symbolptag)))]

20070302 02:47:36 05:00



[(E x) (nop)])








(defineprimop $setsymbolplist! unsafe

20070602 03:21:05 04:00



[(E x v) (memassign v (T x) ( dispsymbolrecordplist symbolptag))])

20070302 02:47:36 05:00







(defineprimop $symbolvalue unsafe

20070602 03:21:05 04:00



[(V x) (prm 'mref (T x) (K ( dispsymbolrecordvalue symbolptag)))]

20070302 02:47:36 05:00



[(E x) (nop)])








(defineprimop $setsymbolvalue! unsafe




[(E x v)




(withtmp ([x (T x)])

20070602 03:21:05 04:00



(prm 'mset x (K ( dispsymbolrecordvalue symbolptag)) (T v))

20070302 02:47:36 05:00



(dirtyvectorset x))])





20070828 23:49:50 04:00



(defineprimop $setsymbolproc! unsafe




[(E x v)




(withtmp ([x (T x)])




(prm 'mset x (K ( dispsymbolrecordproc symbolptag)) (T v))




(dirtyvectorset x))])

20070602 21:55:40 04:00




20080210 05:24:16 05:00



(defineprimop $setsymbolvalue/proc! unsafe




[(E x v)




(withtmp ([x (T x)] [v (T v)])




(prm 'mset x (K ( dispsymbolrecordvalue symbolptag)) v)




(prm 'mset x (K ( dispsymbolrecordproc symbolptag)) v)




(dirtyvectorset x))])





20070302 02:47:36 05:00



(defineprimop toplevelvalue safe




[(V x)

20071012 02:59:27 04:00



(structcase x

20070302 02:47:36 05:00



[(constant s)




(if (symbol? s)




(withtmp ([v (cogenvalue$symbolvalue x)])




(interruptwhen (cogenpred$unboundobject? v))




v)




(interrupt))]

20081012 01:15:20 04:00



[(known expr t)




(cogenvaluetoplevelvalue expr)]

20070302 02:47:36 05:00



[else




(withtmp ([x (T x)])




(interruptunless (cogenpredsymbol? x))




(withtmp ([v (cogenvalue$symbolvalue x)])




(interruptwhen (cogenpred$unboundobject? v))




v))])]




[(E x)

20071012 02:59:27 04:00



(structcase x

20070302 02:47:36 05:00



[(constant s)




(if (symbol? s)




(withtmp ([v (cogenvalue$symbolvalue x)])




(interruptwhen (cogenpred$unboundobject? v)))




(interrupt))]

20081012 01:15:20 04:00



[(known expr t)




(cogeneffecttoplevelvalue expr)]

20070302 02:47:36 05:00



[else




(withtmp ([x (T x)])




(interruptunless (cogenpredsymbol? x))




(withtmp ([v (cogenvalue$symbolvalue x)])




(interruptwhen (cogenpred$unboundobject? v))))])])





20070303 23:17:04 05:00







(defineprimop $initsymbolfunction! unsafe




[(E x v)




(withtmp ([x (T x)] [v (T v)])

20070602 03:21:05 04:00



(prm 'mset x (K ( dispsymbolrecordproc symbolptag)) v)

20070303 23:17:04 05:00



(dirtyvectorset x))])









20070302 02:47:36 05:00



/section)








(section ;;; fixnums








(defineprimop fixnum? safe

20080103 04:42:10 05:00



[(P x) (tagtest (T x) fxmask fxtag)]

20070302 02:47:36 05:00



[(E x) (nop)])





20070915 02:06:16 04:00







(defineprimop fixnumwidth safe




[(V) (K (fxsll ( (* wordsize 8) fxshift) fxshift))]




[(E) (nop)]




[(P) (K #t)])








(defineprimop leastfixnum safe




[(V) (K (sll ( (expt 2 ( ( (* wordsize 8) fxshift) 1)))




fxshift))]




[(E) (nop)]




[(P) (K #t)])








(defineprimop greatestfixnum safe




[(V) (K (sll ( (expt 2 ( ( (* wordsize 8) fxshift) 1)) 1)




fxshift))]




[(E) (nop)]




[(P) (K #t)])













20070915 01:54:45 04:00




20070302 02:47:36 05:00



(defineprimop $fxzero? unsafe




[(P x) (prm '= (T x) (K 0))]




[(E x) (nop)])








(defineprimop $fx= unsafe




[(P x y) (prm '= (T x) (T y))]




[(E x y) (nop)])








(defineprimop $fx< unsafe




[(P x y) (prm '< (T x) (T y))]




[(E x y) (nop)])








(defineprimop $fx<= unsafe




[(P x y) (prm '<= (T x) (T y))]




[(E x y) (nop)])








(defineprimop $fx> unsafe




[(P x y) (prm '> (T x) (T y))]




[(E x y) (nop)])








(defineprimop $fx>= unsafe




[(P x y) (prm '>= (T x) (T y))]




[(E x y) (nop)])








(defineprimop $fxadd1 unsafe




[(V x) (cogenvalue$fx+ x (K 1))]




[(P x) (K #t)]




[(E x) (nop)])








(defineprimop $fxsub1 unsafe




[(V x) (cogenvalue$fx+ x (K 1))]




[(P x) (K #t)]




[(E x) (nop)])








(defineprimop $fx+ unsafe




[(V x y) (prm 'int+ (T x) (T y))]




[(P x y) (K #t)]




[(E x y) (nop)])








(defineprimop $fx* unsafe




[(V a b)

20071012 02:59:27 04:00



(structcase a

20070302 02:47:36 05:00



[(constant a)

20080722 01:07:31 04:00



(unless (fx? a) (interrupt))

20070302 02:47:36 05:00



(prm 'int* (T b) (K a))]

20080707 02:48:16 04:00



[(known a t) (cogenvalue$fx* a b)]

20070302 02:47:36 05:00



[else

20071012 02:59:27 04:00



(structcase b

20070302 02:47:36 05:00



[(constant b)

20080722 01:07:31 04:00



(unless (fx? b) (interrupt))

20070302 02:47:36 05:00



(prm 'int* (T a) (K b))]

20080707 02:48:16 04:00



[(known b t) (cogenvalue$fx* a b)]

20070302 02:47:36 05:00



[else

20080103 04:42:10 05:00



(prm 'int* (T a) (prm 'sra (T b) (K fxshift)))])])]

20070302 02:47:36 05:00



[(P x y) (K #t)]




[(E x y) (nop)])








(defineprimop $fxlognot unsafe




[(V x) (cogenvalue$fxlogxor x (K 1))]




[(P x) (K #t)]




[(E x) (nop)])








(defineprimop $fxlogand unsafe




[(V x y) (prm 'logand (T x) (T y))]




[(P x y) (K #t)]




[(E x y) (nop)])








(defineprimop $fxlogor unsafe




[(V x y) (prm 'logor (T x) (T y))]




[(P x y) (K #t)]




[(E x y) (nop)])








(defineprimop $fxlogxor unsafe




[(V x y) (prm 'logxor (T x) (T y))]




[(P x y) (K #t)]




[(E x y) (nop)])








(defineprimop $fx unsafe




[(V x y) (prm 'int (T x) (T y))]




[(P x y) (K #t)]




[(E x y) (nop)])








(defineprimop $fxsll unsafe




[(V x i)

20071012 02:59:27 04:00



(structcase i

20070302 02:47:36 05:00



[(constant i)

20080718 04:35:13 04:00



(unless (fx? i) (interrupt))

20070302 02:47:36 05:00


