conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

WIP on tag analysis, annotations, and utilization.

This commit is contained in:
Abdulaziz Ghuloum 2008-07-06 23:48:16 -07:00
parent d73dfd1287
commit 579b823f44
14 changed files with 1240 additions and 395 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
scheme/Makefile.am
View File

@ -24,7 +24,8 @@ EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss \
psyntax.internal.ss psyntax.library-manager.ss \
unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss \
ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss
ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss
all: $(nodist_pkglib_DATA)

3
scheme/Makefile.in
View File

@ -178,7 +178,8 @@ EXTRA_DIST = ikarus.boot.prebuilt ikarus.enumerations.ss \
psyntax.internal.ss psyntax.library-manager.ss \
unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss \
ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss
ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss
revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
CLEANFILES = $(nodist_pkglib_DATA) ikarus.config.ss

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

101
scheme/ikarus.compiler.altcogen.ss
View File

@ -67,6 +67,13 @@
(define (mkfuncall op arg*)
(import primops)
(struct-case op
[(known x t)
(struct-case x
[(primref name)
(if (primop? name)
(make-primcall name arg*)
(make-funcall op arg*))]
[else (make-funcall op arg*)])]
[(primref name)
(cond
[(primop? name)
@ -74,6 +81,10 @@
[else (make-funcall op arg*)])]
[else (make-funcall op arg*)]))
;;;
(define (A x)
(struct-case x
[(known x t) (make-known (Expr x) t)]
[else (Expr x)]))
(define (Expr x)
(struct-case x
[(constant) x]
@ -91,11 +102,9 @@
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator arg*)
(mkfuncall (Expr rator) (map Expr arg*))]
(mkfuncall (A rator) (map A arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
[else (error who "invalid expr" x)]))
;;;
(define (ClambdaCase x)
@ -142,6 +151,10 @@
[(closure code free* well-known?)
(make-closure code (map Var free*) well-known?)]))
(make-fix lhs* (map handle-closure rhs*) body))
(define (A x)
(struct-case x
[(known x t) (make-known (Expr x) t)]
[else (Expr x)]))
(define (Expr x)
(struct-case x
[(constant) x]
@ -159,15 +172,13 @@
(let ([t (unique-var 'tmp)])
(Expr (make-fix (list t) (list x) t)))]
[(primcall op arg*)
(make-primcall op (map Expr arg*))]
(make-primcall op (map A arg*))]
[(forcall op arg*)
(make-forcall op (map Expr arg*))]
[(funcall rator arg*)
(make-funcall (Expr rator) (map Expr arg*))]
(make-funcall (A rator) (map A arg*))]
[(jmpcall label rator arg*)
(make-jmpcall label (Expr rator) (map Expr arg*))]
[(mvcall rator k)
(make-mvcall (Expr rator) (Clambda k))]
[else (error who "invalid expr" x)]))
Expr)
;;;
@ -208,20 +219,28 @@
(define (insert-engine-checks x)
(define who 'insert-engine-checks)
(define (known-primref? x)
(struct-case x
[(known x t) (known-primref? x)]
[(primref) #t]
[else #f]))
(define (A x)
(struct-case x
[(known x t) (Expr x)]
[else (Expr x)]))
(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)]
(if (known-primref? rator) (ormap A 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*)]
[(primcall op arg*) (ormap A arg*)]
[(forcall op arg*) (ormap Expr arg*)]
[else (error who "invalid expr" x)]))
(define (Main x)
@ -245,6 +264,10 @@
(define (insert-stack-overflow-check x)
(define who 'insert-stack-overflow-check)
(define (A x)
(struct-case x
[(known x t) (NonTail x)]
[else (NonTail x)]))
(define (NonTail x)
(struct-case x
[(constant) #f]
@ -257,8 +280,9 @@
[(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*)]
[(primcall op arg*) (ormap A arg*)]
[(forcall op arg*) (ormap NonTail arg*)]
[(known x t v) (NonTail x)]
[else (error who "invalid expr" x)]))
(define (Tail x)
(struct-case x
@ -295,58 +319,6 @@
(make-codes (map Clambda code*) (Main body))]))
(Program x))
(define (insert-dummy-type-annotations x)
(define who 'insert-dummy-type-annotations)
(define (Closure x)
(struct-case x
[(closure code free*)
x]
;(make-closure (Expr code) (map Var free*))]
[else (error who "not a closure" x)]))
(define (Expr x)
(struct-case x
[(constant i)
(make-known x 'constant i)]
[(var) x]
[(primref op)
(make-known x 'primitive op)]
[(bind lhs* rhs* body)
(make-bind lhs* (map Expr rhs*) (Expr body))]
[(fix lhs* rhs* body)
(make-fix lhs* (map Closure rhs*) (Expr body))]
[(conditional e0 e1 e2)
(make-conditional (Expr e0) (Expr e1) (Expr e2))]
[(seq e0 e1)
(make-seq (Expr e0) (Expr e1))]
[(primcall op arg*)
(make-primcall op (map Expr arg*))]
[(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) (Expr k))]
[else (error who "invalid expr" x)]))
(define (ClambdaCase x)
(struct-case x
[(clambda-case info body)
(make-clambda-case info (Expr body))]))
(define (Clambda x)
(struct-case x
[(clambda label case* cp free* name)
(make-clambda label (map ClambdaCase case*) cp free* name)]))
(define (Program x)
(struct-case x
[(codes code* body)
(make-codes (map Clambda code*) (Expr body))]))
(Program x))
(include "pass-specify-rep.ss")
(define parameter-registers '(%edi))
@ -392,6 +364,7 @@
(do-bind lhs* rhs* (S body k))]
[(seq e0 e1)
(make-seq (E e0) (S e1 k))]
[(known x) (S x k)]
[else
(cond
[(or (constant? x) (symbol? x)) (k x)]
@ -604,6 +577,7 @@
(make-shortcut
(V d body)
(V d handler))]
[(known x) (V d x)]
[else
(if (symbol? x)
(make-set d x)
@ -3012,7 +2986,6 @@
[x (eliminate-fix x)]
[x (insert-engine-checks x)]
[x (insert-stack-overflow-check x)]
;[x (insert-dummy-type-annotations x)]
[x (specify-representation x)]
[x (impose-calling-convention/evaluation-order x)]
[x (time-it "frame" (lambda () (assign-frame-sizes x)))]

3
scheme/ikarus.compiler.source-optimizer.ss
View File

@ -106,9 +106,6 @@
(define cp0-effort-limit (make-parameter 50))
(define cp0-size-limit (make-parameter 8))
;(define cp0-effort-limit (make-parameter 100))
;(define cp0-size-limit (make-parameter 10))
(define primitive-info-list
'(

127
scheme/ikarus.compiler.ss
View File

@ -19,7 +19,8 @@
assembler-output optimize-cp
current-primitive-locations eval-core
compile-core-expr expand/optimize optimizer-output
cp0-effort-limit cp0-size-limit optimize-level)
cp0-effort-limit cp0-size-limit optimize-level
perform-tag-analysis tag-analysis-output)
(import
(rnrs hashtables)
(ikarus system $fx)
@ -32,7 +33,8 @@
compile-core-expr-to-port assembler-output
current-primitive-locations eval-core
cp0-size-limit cp0-effort-limit
expand/optimize optimizer-output)
expand/optimize optimizer-output
tag-analysis-output perform-tag-analysis)
(ikarus.fasl.write)
(ikarus.intel-assembler))
@ -139,7 +141,7 @@
(define-struct assign (lhs rhs))
(define-struct mvcall (producer consumer))
(define-struct known (expr type value))
(define-struct known (expr type))
(define-struct shortcut (body handler))
@ -440,9 +442,10 @@
(define (E x)
(struct-case x
[(constant c) `(quote ,c)]
[(known x t) `(known ,(E x) ,(T:description t))]
[(code-loc x) `(code-loc ,x)]
[(var x) (string->symbol (format ":~a" x))]
[(prelex name) (string->symbol (format ":~a" x))]
[(prelex name) (string->symbol (format ":~a" name))]
[(primref x) x]
[(conditional test conseq altern)
`(if ,(E test) ,(E conseq) ,(E altern))]
@ -1121,6 +1124,8 @@
[else (error who "invalid expression" (unparse x))]))
(Expr x))
(include "ikarus.compiler.tag-annotation-analysis.ss")
(define (introduce-vars x)
(define who 'introduce-vars)
(define (lookup x)
@ -1134,6 +1139,10 @@
(set-var-global-loc! v (prelex-global-location x))
(set-prelex-operand! x v)
v))
(define (A x)
(struct-case x
[(known x t) (make-known (E x) t)]
[else (E x)]))
(define (E x)
(struct-case x
[(constant) x]
@ -1163,9 +1172,9 @@
cls*)
cp free name)]
[(primcall rator rand*)
(make-primcall rator (map E rand*))]
(make-primcall rator (map A rand*))]
[(funcall rator rand*)
(make-funcall (E rator) (map E rand*))]
(make-funcall (A rator) (map A rand*))]
[(forcall rator rand*) (make-forcall rator (map E rand*))]
[(assign lhs rhs)
(make-assign (lookup lhs) (E rhs))]
@ -1192,6 +1201,10 @@
(if (null? lhs*)
(Expr body)
(make-fix lhs* (map CLambda rhs*) (Expr body))))
(define (A x)
(struct-case x
[(known x t) (make-known (Expr x) t)]
[else (Expr x)]))
(define (Expr x)
(struct-case x
[(constant) x]
@ -1217,12 +1230,22 @@
[(forcall op rand*)
(make-forcall op (map Expr rand*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
(make-funcall (A rator) (map A rand*))]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
[else (error who "invalid expression" (unparse x))]))
(Expr x))
(define (untag x)
(struct-case x
[(known x t) (values x t)]
[else (values x #f)]))
(define (tag x t)
(if t
(make-known x t)
x))
(define (optimize-for-direct-jumps x)
(define who 'optimize-for-direct-jumps)
(define (init-var x)
@ -1252,20 +1275,24 @@
(cond
[proper
(if (fx= n (length fml*))
(make-jmpcall label rator rand*)
(make-jmpcall label (strip rator) (map strip rand*))
(f (cdr cls*)))]
[else
(if (fx<= (length (cdr fml*)) n)
(make-jmpcall label rator
(make-jmpcall label (strip rator)
(let f ([fml* (cdr fml*)] [rand* rand*])
(cond
[(null? fml*)
;;; FIXME: construct list afterwards
(list (make-funcall (make-primref 'list) rand*))]
[else
(cons (car rand*)
(cons (strip (car rand*))
(f (cdr fml*) (cdr rand*)))])))
(f (cdr cls*)))])])]))])))
(define (strip x)
(struct-case x
[(known x t) x]
[else x]))
(define (CLambda x)
(struct-case x
[(clambda g cls* cp free name)
@ -1277,6 +1304,14 @@
(make-clambda-case info (Expr body))]))
cls*)
cp free name)]))
(define (A x)
(struct-case x
[(known x t) (make-known (Expr x) t)]
[else (Expr x)]))
(define (A- x)
(struct-case x
[(known x t) (Expr x)]
[else (Expr x)]))
(define (Expr x)
(struct-case x
[(constant) x]
@ -1296,19 +1331,18 @@
[(forcall op rand*)
(make-forcall op (map Expr rand*))]
[(funcall rator rand*)
(let ([rator (Expr rator)])
(let-values ([(rator t) (untag (A rator))])
(cond
[(and (var? rator) (bound-var rator)) =>
(lambda (c)
(optimize c rator (map Expr rand*)))]
(optimize c rator (map A rand*)))]
[(and (primref? rator)
(eq? (primref-name rator) '$$apply))
(make-jmpcall (sl-apply-label)
(Expr (car rand*))
(map Expr (cdr rand*)))]
(make-jmpcall (sl-apply-label)
(A- (car rand*))
(map A- (cdr rand*)))]
[else
(make-funcall rator (map Expr rand*))]))]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
(make-funcall (tag rator t) (map A rand*))]))]
[else (error who "invalid expression" (unparse x))]))
(Expr x))
@ -1335,6 +1369,10 @@
(list (make-constant loc) (car lhs*)))
(global-assign (cdr lhs*) body)))]
[else (global-assign (cdr lhs*) body)]))
(define (A x)
(struct-case x
[(known x t) (make-known (Expr x) t)]
[else (Expr x)]))
(define (Expr x)
(struct-case x
[(constant) x]
@ -1367,11 +1405,14 @@
[(forcall op rand*)
(make-forcall op (map Expr rand*))]
[(funcall rator rand*)
(make-funcall (Expr rator) (map Expr rand*))]
[(mvcall p c) (make-mvcall (Expr p) (Expr c))]
(make-funcall (A rator) (map A rand*))]
[(jmpcall label rator rand*)
(make-jmpcall label (Expr rator) (map Expr rand*))]
[else (error who "invalid expression" (unparse x))]))
(define (AM x)
(struct-case x
[(known x t) (make-known (Main x) t)]
[else (Main x)]))
(define (Main x)
(struct-case x
[(constant) x]
@ -1397,8 +1438,7 @@
[(forcall op rand*)
(make-forcall op (map Main rand*))]
[(funcall rator rand*)
(make-funcall (Main rator) (map Main rand*))]
[(mvcall p c) (make-mvcall (Main p) (Main c))]
(make-funcall (AM rator) (map AM rand*))]
[(jmpcall label rator rand*)
(make-jmpcall label (Main rator) (map Main rand*))]
[else (error who "invalid expression" (unparse x))]))
@ -1448,6 +1488,19 @@
free
#f)
free))]))
(define (A x)
(struct-case x
[(known x t)
(let-values ([(x free) (Expr x)])
(values (make-known x t) free))]
[else (Expr x)]))
(define (A* x*)
(cond
[(null? x*) (values '() '())]
[else
(let-values ([(a a-free) (A (car x*))]
[(d d-free) (A* (cdr x*))])
(values (cons a d) (union a-free d-free)))]))
(define (Expr ex)
(struct-case ex
[(constant) (values ex '())]
@ -1486,19 +1539,25 @@
(let-values ([(rand* rand*-free) (Expr* rand*)])
(values (make-forcall op rand*) rand*-free))]
[(funcall rator rand*)
(let-values ([(rator rat-free) (Expr rator)]
[(rand* rand*-free) (Expr* rand*)])
(values (make-funcall rator rand*)
(let-values ([(rator rat-free) (A rator)]
[(rand* rand*-free) (A* rand*)])
(values (make-funcall rator rand*)
(union rat-free rand*-free)))]
[(jmpcall label rator rand*)
(let-values ([(rator rat-free)
(if (and (optimize-cp) (var? rator))
(values rator (singleton rator))
(Expr rator))]
[(rand* rand*-free) (Expr* rand*)])
(if (optimize-cp) (Rator rator) (Expr rator))]
[(rand* rand*-free)
(A* rand*)])
(values (make-jmpcall label rator rand*)
(union rat-free rand*-free)))]
(union rat-free rand*-free)))]
[else (error who "invalid expression" ex)]))
(define (Rator x)
(struct-case x
[(var) (values x (singleton x))]
;[(known x t)
; (let-values ([(x free) (Rator x)])
; (values (make-known x t) free))]
[else (Expr x)]))
(let-values ([(prog free) (Expr prog)])
(unless (null? free)
(error 'convert-closures "free vars encountered in program"
@ -1696,6 +1755,10 @@
y)]
[else y]))]
[else x])))
(define (A x)
(struct-case x
[(known x t) (make-known (E x) t)]
[else (E x)]))
(define (E x)
(struct-case x
[(constant) x]
@ -1707,7 +1770,7 @@
(make-conditional (E test) (E conseq) (E altern))]
[(seq e0 e1) (make-seq (E e0) (E e1))]
[(forcall op rand*) (make-forcall op (map E rand*))]
[(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
[(funcall rator rand*) (make-funcall (A rator) (map A rand*))]
[(jmpcall label rator rand*)
(make-jmpcall label (E rator) (map E rand*))]
[else (error who "invalid expression" (unparse x))]))
@ -2267,6 +2330,7 @@
(printf " ~s\n" x)]))
(define optimizer-output (make-parameter #f))
(define perform-tag-analysis (make-parameter #f))
(define (compile-core-expr->code p)
(let* ([p (recordize p)]
@ -2280,6 +2344,9 @@
(pretty-print (unparse-pretty p)))
#f)]
[p (rewrite-assignments p)]
[p (if (perform-tag-analysis)
(introduce-tags p)
p)]
[p (introduce-vars p)]
[p (sanitize-bindings p)]
[p (optimize-for-direct-jumps p)]

434
scheme/ikarus.compiler.tag-annotation-analysis.ss Normal file
View File

@ -0,0 +1,434 @@
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;;
;;; 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/>.
;;; THIS IS WIP
(include "ikarus.ontology.ss")
(define tag-analysis-output (make-parameter #f))
(define (introduce-tags x)
(define who 'introduce-tags)
#;
(define primitive-return-types
'(
[length fixnum]
[bytevector-length fixnum]
[bytevector-u8-ref fixnum]
[bytevector-s8-ref fixnum]
[bytevector-u16-ref fixnum]
[bytevector-s16-ref fixnum]
[bytevector-u16-native-ref fixnum]
[bytevector-s16-native-ref fixnum]
[fixnum-width fixnum]
[greatest-fixnum fixnum]
[least-fixnum fixnum]
[= boolean]
[< boolean]
[<= boolean]
[> boolean]
[>= boolean]
[even? boolean]
[odd? boolean]
[rational? boolean]
[rational-valued? boolean]
[real? boolean]
[real-valued? boolean]
[bignum? boolean]
[ratnum? boolean]
[flonum? boolean]
[fixnum? boolean]
[integer? boolean]
[exact? boolean]
[finite? boolean]
[inexact? boolean]
[infinite? boolean]
[positive? boolean]
[negative? boolean]
[nan? boolean]
[number? boolean]
[compnum? boolean]
[cflonum? boolean]
[complex? boolean]
[list? boolean]
[eq? boolean]
[eqv? boolean]
[equal? boolean]
[gensym? boolean]
[symbol-bound? boolean]
[code? boolean]
[immediate? boolean]
[pair? boolean]
[procedure? boolean]
[symbol? boolean]
[symbol=? boolean]
[boolean? boolean]
[boolean=? boolean]
[vector? boolean]
[bitwise-bit-set? boolean]
[bytevector? boolean]
[bytevector=? boolean]
[enum-set=? boolean]
[binary-port? boolean]
[textual-port? boolean]
[input-port? boolean]
[output-port? boolean]
[port? boolean]
[port-eof? boolean]
[port-closed? boolean]
[char-ready? boolean]
[eof-object? boolean]
[hashtable? boolean]
[hashtable-mutable? boolean]
[file-exists? boolean]
[file-regular? boolean]
[file-directory? boolean]
[file-symbolic-link? boolean]
[record? boolean]
[record-field-mutable? boolean]
[record-type-generative? boolean]
[record-type-sealed? boolean]
[record-type-descriptor boolean]
[free-identifier=? boolean]
[bound-identifier=? boolean]
[identifier? boolean]
[char-lower-case? boolean]
[char-upper-case? boolean]
[char-title-case? boolean]
[char-whitespace? boolean]
[char-numeric? boolean]
[char-alphabetic? boolean]
))
(define number!
(let ([i 0])
(lambda (x)
(set-prelex-operand! x i)
(set! i (+ i 1)))))
(define (V* x* env)
(cond
[(null? x*) (values '() env '())]
[else
(let-values ([(x env1 t) (V (car x*) env)]
[(x* env2 t*) (V* (cdr x*) env)])
(values (cons x x*)
(and-envs env1 env2)
(cons t t*)))]))
(define (constant-type x)
(define (numeric x)
(define (size x t)
(T:and t
(cond
[(< x 0) T:negative]
[(> x 0) T:positive]
[(= x 0) T:zero]
[else t])))
(cond
[(fixnum? x) (size x T:fixnum)]
[(flonum? x) (size x T:flonum)]
[(or (bignum? x) (ratnum? x))
(size x (T:and T:exact T:other-number))]
[else T:number]))
(cond
[(number? x) (numeric x)]
[(boolean? x) (if x T:true T:false)]
[(null? x) T:null]
[(char? x) T:char]
[(string? x) T:string]
[(vector? x) T:vector]
[(pair? x) T:pair]
[(eq? x (void)) T:void]
[else T:object]))
(define (V x env)
(struct-case x
[(constant k) (values x env (constant-type k))]
[(prelex) (values x env (lookup x env))]
[(primref op) (values x env T:procedure)]
[(seq e0 e1)
(let-values ([(e0 env t) (V e0 env)])
(cond
[(eq? (T:object? t) 'no)
(values e0 env t)]
[else
(let-values ([(e1 env t) (V e1 env)])
(values (make-seq e0 e1) env t))]))]
[(conditional e0 e1 e2)
(let-values ([(e0 env t) (V e0 env)])
(cond
[(eq? (T:object? t) 'no)
(values e0 env t)]
[(eq? (T:false? t) 'yes)
(let-values ([(e2 env t) (V e2 env)])
(values (make-seq e0 e2) env t))]
[(eq? (T:false? t) 'no)
(let-values ([(e1 env t) (V e1 env)])
(values (make-seq e0 e1) env t))]
[else
(let-values ([(e1 env1 t1) (V e1 env)]
[(e2 env2 t2) (V e2 env)])
(values (make-conditional e0 e1 e2)
(or-envs env1 env2)
(T:or t1 t2)))]))]
[(bind lhs* rhs* body)
(let-values ([(rhs* env t*) (V* rhs* env)])
(for-each number! lhs*)
(let ([env (extend-env* lhs* t* env)])
(let-values ([(body env t) (V body env)])
(values
(make-bind lhs* rhs* body)
env t))))]
[(fix lhs* rhs* body)
(for-each number! lhs*)
(let-values ([(rhs* env t*) (V* rhs* env)])
(let ([env (extend-env* lhs* t* env)])
(let-values ([(body env t) (V body env)])
(values
(make-fix lhs* rhs* body)
env t))))]
[(clambda g cls* cp free name)
(values
(make-clambda g
(map
(lambda (x)
(struct-case x
[(clambda-case info body)
(for-each number! (case-info-args info))
(let-values ([(body env t) (V body env)])
;;; dropped env and t
(make-clambda-case info body))]))
cls*)
cp free name)
env
T:procedure)]
[(funcall rator rand*)
(let-values ([(rator rator-env rator-val) (V rator env)]
[(rand* rand*-env rand*-val) (V* rand* env)])
(apply-funcall rator rand*
rator-val rand*-val
rator-env rand*-env))]
[(forcall rator rand*)
(let-values ([(rand* rand*-env rand*-val) (V* rand* env)])
(values (make-forcall rator rand*)
rand*-env
T:object))]
[else (error who "invalid expression" (unparse x))]))
(define (annotate x t)
(cond
[(T=? t T:object) x]
[else (make-known x t)]))
(define (apply-funcall rator rand* rator-val rand*-val rator-env rand*-env)
(let ([env (and-envs rator-env rand*-env)]
[rand* (map annotate rand* rand*-val)])
(struct-case rator
[(primref op)
(apply-primcall op rand* env)]
[else
(values (make-funcall (annotate rator rator-val) rand*)
env
T:object)])))
(define (apply-primcall op rand* env)
(define (return t)
(values (make-funcall (make-primref op) rand*) env t))
(define (inject ret-t . rand-t*)
(define (extend* x* t* env)
(define (extend x t env)
(struct-case x
[(known expr t0)
(extend expr (T:and t t0) env)]
[(prelex)
(extend-env x t env)]
[else env]))
(cond
[(null? x*) env]
[else (extend (car x*) (car t*)
(extend* (cdr x*) (cdr t*) env))]))
(cond
[(= (length rand-t*) (length rand*))
(values (make-funcall (make-primref op) rand*)
(extend* rand* rand-t* env)
ret-t)]
[else
(error 'apply-primcall "invalid extesion" op rand*)]))
(define (inject* ret-t arg-t)
(define (extend* x* env)
(define (extend x t env)
(struct-case x
[(known expr t0)
(extend expr (T:and t t0) env)]
[(prelex)
(extend-env x t env)]
[else env]))
(cond
[(null? x*) env]
[else (extend (car x*) arg-t
(extend* (cdr x*) env))]))
(values (make-funcall (make-primref op) rand*)
(extend* rand* env)
ret-t))
(case op
[(cons)
(return T:pair)]
[(car 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)
(inject T:object T:pair)]
[(set-car! set-cdr!)
(inject T:void T:pair T:object)]
[(vector make-vector list->vector)
(return T:vector)]
[(string make-string list->string)
(return T:string)]
[(string-length)
(inject T:fixnum T:string)]
[(vector-length)
(inject T:fixnum T:vector)]
[(string-ref)
(inject T:char T:string T:fixnum)]
[(string-set!)
(inject T:void T:string T:fixnum T:char)]
[(vector-ref)
(inject T:object T:vector T:fixnum)]
[(vector-set!)
(inject T:void T:vector T:fixnum T:object)]
[(integer->char)
(inject T:char T:fixnum)]
[(char->integer)
(inject T:fixnum T:char)]
[(fx+ fx- fx* fxadd1 fxsub1
fxquotient fxremainder fxmodulo fxsll fxsra
fxand fxdiv fxdiv0 fxif fxior
fxlength fxmax fxmin fxmod fxmod0
fxnot fxxor fxlogand fxlogor fxlognot
fxlogxor fxlogand fxlogand fxlogand fxlogand
fxlogand fxlogand)
(inject* T:fixnum T:fixnum)]
[(fx= fx< fx<= fx> fx>= fx=? fx<? fx<=? fx>? fx>=?
fxeven? fxodd? fxnegative? fxpositive? fxzero?
fxbit-set?)
(inject* T:boolean T:fixnum)]
[(fl=? fl<? fl<=? fl>? fl>=?
fleven? flodd? flzero? flpositive? flnegative?
flfinite? flinfinite? flinteger? flnan?)
(inject* T:boolean T:flonum)]
[(char=? char<? char<=? char>? char>=?
char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?)
(inject* T:boolean T:char)]
[(string=? string<? string<=? string>? string>=?
string-ci=? string-ci<? string-ci<=? string-ci>?
string-ci>=?)
(inject* T:boolean T:string)]
[(make-parameter
record-constructor
record-accessor
record-constructor
record-predicate
condition-accessor
condition-predicate
enum-set-constructor
enum-set-indexer
make-guardian)
(return T:procedure)]
[else
(return T:object)]))
;;;
(define (extend-env* x* v* env)
(cond
[(null? x*) env]
[else
(extend-env* (cdr x*) (cdr v*)
(extend-env (car x*) (car v*) env))]))
(define (extend-env x t env)
(cond
[(T=? t T:object) env]
[else
(let ([x (prelex-operand x)])
(let f ([env env])
(cond
[(or (null? env) (< x (caar env)))
(cons (cons x t) env)]
[else
(cons (car env) (f (cdr env)))])))]))
(define (or-envs env1 env2)
(define (cons-env x v env)
(cond
[(T=? v T:object) env]
[else (cons (cons x v) env)]))
(define (merge-envs1 a1 env1 env2)
(if (pair? env2)
(merge-envs2 a1 env1 (car env2) (cdr env2))
empty-env))
(define (merge-envs2 a1 env1 a2 env2)
(let ([x1 (car a1)] [x2 (car a2)])
(if (eq? x1 x2)
(cons-env x1 (T:or (cdr a1) (cdr a2))
(merge-envs env1 env2))
(if (< x2 x1)
(merge-envs1 a1 env1 env2)
(merge-envs1 a2 env2 env1)))))
(define (merge-envs env1 env2)
(if (eq? env1 env2)
env1
(if (pair? env1)
(if (pair? env2)
(merge-envs2 (car env1) (cdr env1) (car env2) (cdr env2))
empty-env)
empty-env)))
(merge-envs env1 env2))
(define (and-envs env1 env2)
(define (cons-env x v env)
(cond
[(T=? v T:object) env]
[else (cons (cons x v) env)]))
(define (merge-envs1 a1 env1 env2)
(if (pair? env2)
(merge-envs2 a1 env1 (car env2) (cdr env2))
env1))
(define (merge-envs2 a1 env1 a2 env2)
(let ([x1 (car a1)] [x2 (car a2)])
(if (eq? x1 x2)
(cons-env x1 (T:and (cdr a1) (cdr a2))
(merge-envs env1 env2))
(if (< x2 x1)
(cons a2 (merge-envs1 a1 env1 env2))
(cons a1 (merge-envs1 a2 env2 env1))))))
(define (merge-envs env1 env2)
(if (eq? env1 env2)
env1
(if (pair? env1)
(if (pair? env2)
(merge-envs2 (car env1) (cdr env1) (car env2) (cdr env2))
env1)
env2)))
(merge-envs env1 env2))
(define empty-env '())
(define (lookup x env)
(cond
[(eq? env 'bottom) #f]
[else
(let ([x (prelex-operand x)])
(cond
[(assq x env) => cdr]
[else T:object]))]))
(let-values ([(x env t) (V x empty-env)])
(when (tag-analysis-output)
(pretty-print (unparse x)))
x))

16
scheme/ikarus.conditions.ss
View File

@ -72,13 +72,6 @@
&i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd
&no-nans-rtd &no-nans-rcd
&interrupted-rtd &interrupted-rcd
&i/o-would-block-rtd
&i/o-would-block-rcd
make-i/o-would-block-condition
i/o-would-block-condition?
i/o-would-block-port
)
(import
(rnrs records inspection)
@ -131,11 +124,6 @@
i/o-encoding-error? i/o-encoding-error-char
no-infinities-violation? make-no-infinities-violation
no-nans-violation? make-no-nans-violation
&i/o-would-block
make-i/o-would-block-condition
i/o-would-block-condition?
i/o-would-block-port
))
(define-record-type &condition
@ -344,10 +332,6 @@
(define-condition-type &interrupted &serious
make-interrupted-condition interrupted-condition?)
(define-condition-type &i/o-would-block &condition
make-i/o-would-block-condition i/o-would-block-condition?
(port i/o-would-block-port))
(define print-condition
(let ()
(define (print-simple-condition x p)

4
scheme/ikarus.io.ss
View File

@ -1309,8 +1309,6 @@
(cond
[(fx>= bytes 0) bytes]
[(fx= bytes EAGAIN-error-code)
;(raise-continuable
; (make-i/o-would-block-condition port))
(call/cc
(lambda (k)
(add-io-event fd k 'r)
@ -1351,8 +1349,6 @@
(cond
[(fx>= bytes 0) bytes]
[(fx= bytes EAGAIN-error-code)
;(raise-continuable
; (make-i/o-would-block-condition port))
(call/cc
(lambda (k)
(add-io-event fd k 'w)

273
scheme/ikarus.ontology.ss Executable file
View File

@ -0,0 +1,273 @@
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;;
;;; 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/>.
(define-syntax define-ontology
(lambda (x)
(define (make-ontology main ls)
(define (set-cons x ls)
(cond
[(memq x ls) ls]
[else (cons x ls)]))
(define (union ls1 ls2)
(cond
[(null? ls1) ls2]
[else (union (cdr ls1) (set-cons (car ls1) ls2))]))
(define (difference ls1 ls2)
(cond
[(null? ls1) '()]
[(memq (car ls1) ls2) (difference (cdr ls1) ls2)]
[else (cons (car ls1) (difference (cdr ls1) ls2))]))
(define (collect-names ls)
(syntax-case ls ()
[() '()]
[((name (of name* ...)) . rest)
(union (cons #'name #'(name* ...)) (collect-names #'rest))]))
(define (expand x all)
(define (lookup x ls)
(cond
[(null? ls) (values 'tag '())]
[else
(let ([a (car ls)])
(cond
[(eq? x (car a))
(values (cadr a) (cdr ls))]
[else
(let-values ([(xp ls) (lookup x (cdr ls))])
(values xp (cons a ls)))]))]))
(let f ([x x] [ls ls])
(let-values ([(xp ls) (lookup x ls)])
(cond
[(pair? xp)
(cons (car xp) (map (lambda (x) (f x ls)) (cdr xp)))]
[(eq? xp 'tag) x]
[else (error 'expand-lookup "invalid" xp)]))))
(define (rename alist x)
(cond
[(symbol? x) (cdr (assq x alist))]
[else (cons (car x) (map (lambda (x) (rename alist x)) (cdr x)))]))
(define (enumerate ls)
(let f ([i 1] [ls ls])
(cond
[(null? ls) '()]
[else (cons i (f (* i 2) (cdr ls)))])))
(define (unique-elements x)
(define (exclude m ls)
(cond
[(null? ls) '()]
[(zero? (bitwise-and m (car ls)))
(cons (car ls) (exclude m (cdr ls)))]
[else (exclude m (cdr ls))]))
(define (exclusive* m* x**)
(cond
[(null? (cdr m*)) (values (car m*) (car x**))]
[else
(let-values ([(m1 x1*) (values (car m*) (car x**))]
[(m2 x2*) (exclusive* (cdr m*) (cdr x**))])
(let ([x1* (exclude m2 x1*)]
[x2* (exclude m1 x2*)])
(values (bitwise-ior m1 m2) (append x1* x2*))))]))
(define (inclusive* m* x**)
(cond
[(null? (cdr m*)) (values (car m*) (car x**))]
[else
(let-values ([(m1 x1*) (values (car m*) (car x**))]
[(m2 x2*) (inclusive* (cdr m*) (cdr x**))])
(values (bitwise-ior m1 m2)
(remp not
(apply append
(map (lambda (x)
(map (lambda (y)
(if (= (bitwise-and m1 m2 x)
(bitwise-and m1 m2 y))
(bitwise-ior x y)
#f))
x2*))
x1*)))))]))
(define (f* ls)
(cond
[(null? ls) (values '() '())]
[else
(let-values ([(m x*) (f (car ls))]
[(m* x**) (f* (cdr ls))])
(values (cons m m*) (cons x* x**)))]))
(define (f x)
(cond
[(integer? x) (values x (list x))]
[else
(let ([tag (car x)] [ls (cdr x)])
(let-values ([(m* x**) (f* ls)])
(case tag
[(exclusive) (exclusive* m* x**)]
[(inclusive) (inclusive* m* x**)]
[else (error 'f "invalid")])))]))
(let-values ([(m ls) (f x)])
ls))
(define (expand-names alist)
(lambda (n)
(let f ([alist alist])
(cond
[(null? alist) '()]
[(zero? (bitwise-and n (cdar alist)))
(f (cdr alist))]
[else
(cons (caar alist) (f (cdr alist)))]))))
(define (extend-alist* ls alist)
(define (extend-alist x alist)
(define (lookup x)
(cond
[(assq x alist) => cdr]
[else (error 'lookup "cannot find" x alist)]))
(let ([name (car x)] [info (cadr x)])
(let ([tag (car info)] [x* (map lookup (cdr info))])
(case tag
[(exclusive)
(cons (cons name (apply bitwise-ior x*)) alist)]
[(inclusive)
(assert (= (apply bitwise-ior x*) (apply bitwise-and x*)))
(cons (cons name (apply bitwise-ior x*)) alist)]
[else (assert #f)]))))
(cond
[(null? ls) alist]
[else
(extend-alist (car ls)
(extend-alist* (cdr ls) alist))]))
(let* ([names (difference (collect-names ls) (map car ls))]
[names-alist (map cons names (enumerate names))])
(let* ([expanded (expand main ls)]
[renamed (rename names-alist expanded)])
(let* ([unique* (list-sort < (unique-elements renamed))]
[canonicals (map (expand-names names-alist) unique*)])
(let* ([canonical-alist (map cons canonicals (enumerate canonicals))]
[seed-alist
(map
(lambda (x)
(let ([ls (filter (lambda (y) (memq x (car y))) canonical-alist)])
(cons x (apply bitwise-ior (map cdr ls)))))
names)])
(extend-alist* ls seed-alist))))))
(define (property-names ls)
(cond
[(null? ls) '()]
[else
(let ([fst (car ls)] [rest (property-names (cdr ls))])
(let ([name (car fst)] [info (cadr fst)])
(case (car info)
[(exclusive) rest]
[(inclusive) (append (cdr info) rest)]
[else (assert #f)])))]))
(define (generate-base-cases T main ls)
(define (value-name x)
(datum->syntax T
(string->symbol
(string-append
(symbol->string (syntax->datum T))
":"
(symbol->string x)))))
(define (predicate-name x)
(datum->syntax T
(string->symbol
(string-append
(symbol->string (syntax->datum T))
":"
(symbol->string x)
"?"))))
(let ([maind (syntax->datum main)] [lsd (syntax->datum ls)])
(let ([alist (make-ontology maind lsd)]
[pnames (property-names lsd)])
(let ([alist (remp (lambda (x) (memq (car x) pnames)) alist)])
(map
(lambda (x) (list (value-name (car x))
(predicate-name (car x))
(cdr x)))
alist)))))
(syntax-case x ()
[(_ T T:description T? T:=? T:and T:or [name cls] [name* cls*] ...)
(with-syntax ([((name* predname* val*) ...)
(generate-base-cases #'T #'name
#'([name cls] [name* cls*] ...))])
#'(begin
(define-record-type (T make-T T?)
(sealed #t)
(fields (immutable n T-n)))
(define (T:and x0 x1)
(make-T (bitwise-and (T-n x0) (T-n x1))))
(define (T:or x0 x1)
(make-T (bitwise-ior (T-n x0) (T-n x1))))
(define (test x v)
(let ([bits (bitwise-and x v)])
(cond
[(= 0 (bitwise-and x v)) 'no]
[(= v (bitwise-ior x v)) 'yes]
[else 'maybe])))
(define name* (make-T val*)) ...
(define (predname* x) (test (T-n x) val*)) ...
(define (T:description x)
(let* ([ls '()]
[ls
(case (predname* x)
[(yes) (cons '(name* yes) ls)]
[else ls])]
...)
ls))
(define (T:=? x y)
(= (T-n x) (T-n y)))
))])))
(define-ontology T T:description T? T=? T:and T:or
[object (inclusive obj-tag obj-immediacy obj-truth)]
[obj-immediacy (exclusive nonimmediate immediate)]
[immediate (exclusive fixnum boolean null char void)]
[obj-truth (exclusive false non-false)]
[obj-tag (exclusive procedure string vector pair null
boolean char number void other-object)]
[boolean (exclusive true false)]
[number (inclusive number-tag number-size number-exactness)]
[number-size (exclusive negative zero positive)]
[number-tag (exclusive fixnum flonum other-number)]
[number-exactness (exclusive exact inexact)]
[exact (exclusive fixnum other-exact)]
[inexact (exclusive flonum other-inexact)]
)
#!eof
(define (do-test expr result expected)
(if (equal? result expected)
(printf "OK: ~s -> ~s\n" expr expected)
(error 'test "failed/got/expected" expr result expected)))
(define-syntax test
(syntax-rules ()
[(_ expr expected) (do-test 'expr expr 'expected)]))
(test (T:object? T:object) yes)
(test (T:object? T:true) yes)
(test (T:true? T:object) maybe)
(test (T:true? T:true) yes)
(test (T:true? T:false) no)
(test (T:true? T:null) no)
(test (T:non-false? T:true) yes)
(test (T:non-false? T:null) yes)
(test (T:non-false? T:false) no)
(test (T:non-false? T:boolean) maybe)
(test (T:non-false? T:object) maybe)
(test (T:boolean? T:true) yes)
(test (T:boolean? T:false) yes)
(test (T:boolean? (T:or T:true T:false)) yes)
(test (T:boolean? (T:and T:true T:false)) no)
(test (T:object? (T:and T:true T:false)) no)

2
scheme/last-revision
View File

@ -1 +1 @@
1526
1527

11
scheme/makefile.ss
View File

@ -19,7 +19,7 @@
(import (except (ikarus)
assembler-output optimize-cp optimize-level
cp0-size-limit cp0-effort-limit expand/optimize
optimizer-output))
optimizer-output tag-analysis-output perform-tag-analysis))
(import (ikarus.compiler))
(import (except (psyntax system $bootstrap)
eval-core
@ -27,6 +27,7 @@
compile-core-expr-to-port))
(import (ikarus.compiler)) ; just for fun
(optimize-level 2)
(perform-tag-analysis #t)
(pretty-width 160)
((pretty-format 'fix) ((pretty-format 'letrec)))
@ -1414,8 +1415,6 @@
[&no-nans-rcd]
[&interrupted-rtd]
[&interrupted-rcd]
[&i/o-would-block-rtd]
[&i/o-would-block-rcd]
[tcp-connect i]
[udp-connect i]
[tcp-connect-nonblocking i]
@ -1429,15 +1428,13 @@
[input-socket-buffer-size i]
[output-socket-buffer-size i]
;[&i/o-would-block i]
;[make-i/o-would-block-condition i]
;[i/o-would-block-condition? i]
;[i/o-would-block-port i]
[ellipsis-map ]
[optimize-cp i]
[optimize-level i]
[cp0-size-limit i]
[cp0-effort-limit i]
[tag-analysis-output i]
[perform-tag-analysis i]
))
(define (macro-identifier? x)

544
scheme/pass-specify-rep-primops.ss
View File

@ -39,11 +39,6 @@
(tag-test (prm 'mref x (K (- ptag))) smask stag)
(make-constant #f)))
(define (safe-ref x disp mask tag)
(seq*
(interrupt-unless (tag-test x mask tag))
(prm 'mref x (K (- disp tag)))))
(define (dirty-vector-set address)
(define shift-bits 2)
(prm 'mset
@ -59,9 +54,14 @@
(if (or (fixnum? t) (immediate? t))
(prm 'nop)
(dirty-vector-set addr))]
[(known x t)
(cond
[(eq? (T:immediate? t) 'yes)
(record-optimization 'smart-dirty-vec t)
(nop)]
[else (smart-dirty-vector-set addr x)])]
[else (dirty-vector-set addr)]))
(define (slow-mem-assign v x i)
(with-tmp ([t (prm 'int+ x (K i))])
(make-seq
@ -74,6 +74,12 @@
(if (or (fixnum? t) (immediate? t))
(prm 'mset x (K i) (T v))
(slow-mem-assign v x i))]
[(known expr t)
(cond
[(eq? (T:immediate? t) 'yes)
(record-optimization 'mem-assign v)
(prm 'mset x (K i) (T expr))]
[else (slow-mem-assign expr x i)])]
[else (slow-mem-assign v x i)]))
(define (align-code unknown-amt known-amt)
@ -111,6 +117,7 @@
(define (equable-constant? x)
(struct-case x
[(constant xv) (equable? xv)]
[(known x t) (equable-constant? x)]
[else #f]))
(define-primop eqv? safe
@ -151,7 +158,8 @@
[(E x) (nop)])
(define-primop boolean? safe
[(P x) (tag-test (T x) bool-mask bool-tag)]
[(P x)
(tag-test (T x) bool-mask bool-tag)]
[(E x) (nop)])
(define-primop bwp-object? safe
@ -195,6 +203,8 @@
(prm '= x (T (K (car ls))))
(K #t)
(f (cdr ls)))])))])]
[(known expr t)
(cogen-pred-$memq x expr)]
[else (interrupt)])]
[(V x ls)
(struct-case ls
@ -211,6 +221,8 @@
(prm '= x (T (K (car ls))))
(T (K ls))
(f (cdr ls)))])))])]
[(known expr t)
(cogen-value-$memq x expr)]
[else (interrupt)])]
[(E x ls) (nop)])
@ -223,6 +235,7 @@
(cond
[(list? ls) (nop)]
[else (interrupt)])]
[(known) (error 'translate "memq")]
[else (interrupt)])])
(define (equable? x)
@ -236,6 +249,7 @@
[(and (list? lsv) (andmap equable? lsv))
(cogen-value-$memq x ls)]
[else (interrupt)])]
[(known) (error 'translate "memv")]
[else (interrupt)])]
[(P x ls)
(struct-case ls
@ -244,6 +258,7 @@
[(and (list? lsv) (andmap equable? lsv))
(cogen-pred-$memq x ls)]
[else (interrupt)])]
[(known) (error 'translate "memv")]
[else (interrupt)])]
[(E x ls)
(struct-case ls
@ -251,6 +266,7 @@
(cond
[(list? lsv) (nop)]
[else (interrupt)])]
[(known) (error 'translate "memv")]
[else (interrupt)])])
/section)
@ -258,7 +274,8 @@
(section ;;; pairs
(define-primop pair? safe
[(P x) (tag-test (T x) pair-mask pair-tag)]
[(P x)
(tag-test (T x) pair-mask pair-tag)]
[(E x) (nop)])
(define-primop cons safe
@ -290,29 +307,41 @@
(prm 'mset x (K (- disp-cdr pair-tag)) (T v))
(smart-dirty-vector-set x v))])
(define (assert-pair x)
(struct-case x
[(known x t)
(case (T:pair? t)
[(yes) (record-optimization 'assert-pair x) (nop)]
[(no) (interrupt)]
[else (assert-pair x)])]
[else
(interrupt-unless (tag-test x pair-mask pair-tag))]))
(define-primop car safe
[(V x)
(safe-ref (T x) disp-car pair-mask pair-tag)]
[(E x)
(interrupt-unless (tag-test (T x) pair-mask pair-tag))])
(with-tmp ([x (T x)])
(assert-pair x)
(prm 'mref x (K (- disp-car pair-tag))))]
[(E x) (assert-pair (T x))])
(define-primop cdr safe
[(V x)
(safe-ref (T x) disp-cdr pair-mask pair-tag)]
[(E x)
(interrupt-unless (tag-test (T x) pair-mask pair-tag))])
(with-tmp ([x (T x)])
(assert-pair x)
(prm 'mref x (K (- disp-cdr pair-tag))))]
[(E x) (assert-pair (T x))])
(define-primop set-car! safe
[(E x v)
(with-tmp ([x (T x)])
(interrupt-unless (tag-test x pair-mask pair-tag))
(assert-pair x)
(prm 'mset x (K (- disp-car pair-tag)) (T v))
(smart-dirty-vector-set x v))])
(define-primop set-cdr! safe
[(E x v)
(with-tmp ([x (T x)])
(interrupt-unless (tag-test x pair-mask pair-tag))
(assert-pair x)
(prm 'mset x (K (- disp-cdr pair-tag)) (T v))
(smart-dirty-vector-set x v))])
@ -322,7 +351,7 @@
[(null? ls) (T val)]
[else
(with-tmp ([x (expand-cxr val (cdr ls))])
(interrupt-unless (tag-test x pair-mask pair-tag))
(assert-pair x)
(prm 'mref x
(case (car ls)
[(a) (K (- disp-car pair-tag))]
@ -408,25 +437,60 @@
(section ;;; vectors
(section ;;; helpers
(define (vector-range-check x idx)
(define (check-fx i)
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (K (* i wordsize)) len))
(interrupt-unless-fixnum len))))
(define (check-? idx)
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(define (check-non-vector x idx)
(define (check-fx idx)
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (T idx) len))
(interrupt-unless-fixnum len))))
(define (check-? idx)
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (T idx) len))
(with-tmp ([t (prm 'logor len (T idx))])
(interrupt-unless-fixnum t)))))
(struct-case idx
[(constant i)
(if (and (fixnum? i) (fx>= i 0))
(check-fx idx)
(check-? idx))]
[(known idx idx-t)
(case (T:fixnum? idx-t)
[(yes) (check-fx idx)]
[(maybe) (vector-range-check x idx)]
[else
(printf "vector check with mismatch index tag ~s" idx-t)
(vector-range-check x idx)])]
[else (check-? idx)]))
(define (check-vector x idx)
(define (check-fx idx)
(with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (T idx) len))
(with-tmp ([t (prm 'logor len (T idx))])
(interrupt-unless-fixnum t)))))
(struct-case idx
[(constant i)
(if (and (fixnum? i) (fx>= i 0))
(check-fx i)
(check-? idx))]
[else (check-? idx)]))
(interrupt-unless (prm 'u< (T idx) len))))
(define (check-? idx)
(seq*
(interrupt-unless-fixnum (T idx))
(with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (T idx) len)))))
(struct-case idx
[(constant i)
(if (and (fixnum? i) (fx>= i 0))
(check-fx idx)
(check-? idx))]
[(known idx idx-t)
(case (T:fixnum? idx-t)
[(yes) (check-fx idx)]
[(no) (interrupt)]
[else (check-vector x idx)])]
[else (check-? idx)]))
(struct-case x
[(known x t)
(case (T:vector? t)
[(yes) (record-optimization 'check-vector x) (check-vector x idx)]
[(no) (interrupt)]
[else (check-non-vector x idx)])]
[else (check-non-vector x idx)]))
/section)
(define-primop vector? unsafe
@ -437,30 +501,31 @@
[(V len)
(struct-case len
[(constant i)
(unless (fixnum? i) (interrupt))
(with-tmp ([v (prm 'alloc
(K (align (+ (* i wordsize) disp-vector-data)))
(K vector-tag))])
(prm 'mset v
(K (- disp-vector-length vector-tag))
(K (* i fx-scale)))
v)]
(if (fixnum? i)
(interrupt)
(with-tmp ([v (prm 'alloc
(K (align (+ (* i wordsize) disp-vector-data)))
(K vector-tag))])
(prm 'mset v
(K (- disp-vector-length vector-tag))
(K (* i fx-scale)))
v))]
[(known expr t)
(cogen-value-$make-vector expr)]
[else
(with-tmp ([alen (align-code (T len) disp-vector-data)])
(with-tmp ([v (prm 'alloc alen (K vector-tag))])
(prm 'mset v (K (- disp-vector-length vector-tag)) (T len))
v))])]
(prm 'mset v (K (- disp-vector-length vector-tag)) (T len))
v))])]
[(P len) (K #t)]
[(E len) (nop)])
(define-primop make-vector safe
[(V len)
(with-tmp ([x (make-forcall "ikrt_make_vector1" (list (T len)))])
(with-tmp ([x (make-forcall "ikrt_make_vector1" (list (T len)))])
(interrupt-when (prm '= x (K 0)))
x)])
(define-primop $vector-ref unsafe
[(V x i)
(or
@ -470,6 +535,8 @@
(fx>= i 0)
(prm 'mref (T x)
(K (+ (* i wordsize) (- disp-vector-data vector-tag)))))]
[(known i t)
(cogen-value-$vector-ref x i)]
[else #f])
(prm 'mref (T x)
(prm 'int+ (T i) (K (- disp-vector-data vector-tag)))))]
@ -482,16 +549,30 @@
(define-primop vector-length safe
[(V x)
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([t (cogen-value-$vector-length x)])
(interrupt-unless-fixnum t)
t))]
(struct-case x
[(known x t)
(case (T:vector? t)
[(yes) (record-optimization 'vector-length x) (cogen-value-$vector-length x)]
[(no) (interrupt)]
[else (cogen-value-vector-length x)])]
[else
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([t (cogen-value-$vector-length x)])
(interrupt-unless-fixnum t)
t))])]
[(E x)
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([t (cogen-value-$vector-length x)])
(interrupt-unless-fixnum t)))]
(struct-case x
[(known x t)
(case (T:vector? t)
[(yes) (record-optimization 'vector-length x) (nop)]
[(no) (interrupt)]
[else (cogen-effect-vector-length x)])]
[else
(seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([t (cogen-value-$vector-length x)])
(interrupt-unless-fixnum t)))])]
[(P x)
(seq* (cogen-effect-vector-length x) (K #t))])
@ -512,6 +593,8 @@
(mem-assign v (T x)
(+ (* i wordsize)
(- disp-vector-data vector-tag)))]
[(known i t)
(cogen-effect-$vector-set! x i v)]
[else
(mem-assign v
(prm 'int+ (T x) (T i))
@ -558,6 +641,7 @@
(prm 'mref (T x)
(K (+ (- disp-closure-data closure-tag)
(* i wordsize))))]
[(known) (error 'translate "$cpref")]
[else (interrupt)])])
/section)
@ -635,6 +719,7 @@
(interrupt-when (cogen-pred-$unbound-object? v))
v)
(interrupt))]
[(known) (error 'translate "top-level-value")]
[else
(with-tmp ([x (T x)])
(interrupt-unless (cogen-pred-symbol? x))
@ -648,6 +733,7 @@
(with-tmp ([v (cogen-value-$symbol-value x)])
(interrupt-when (cogen-pred-$unbound-object? v)))
(interrupt))]
[(known) (error 'translate "top-level-value")]
[else
(with-tmp ([x (T x)])
(interrupt-unless (cogen-pred-symbol? x))
@ -659,7 +745,6 @@
[(E x v)
(with-tmp ([x (T x)] [v (T v)])
(prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) v)
;(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
(dirty-vector-set x))])
@ -737,11 +822,13 @@
[(constant a)
(unless (fixnum? a) (interrupt))
(prm 'int* (T b) (K a))]
[(known a t) (cogen-value-$fx* a b)]
[else
(struct-case b
[(constant b)
(unless (fixnum? b) (interrupt))
(prm 'int* (T a) (K b))]
[(known b t) (cogen-value-$fx* a b)]
[else
(prm 'int* (T a) (prm 'sra (T b) (K fx-shift)))])])]
[(P x y) (K #t)]
@ -778,6 +865,7 @@
[(constant i)
(unless (fixnum? i) (interrupt))
(prm 'sll (T x) (K i))]
[(known i t) (cogen-value-$fxsll x i)]
[else
(prm 'sll (T x) (prm 'sra (T i) (K fx-shift)))])]
[(P x i) (K #t)]
@ -791,6 +879,7 @@
(prm 'logand
(prm 'sra (T x) (K (if (> i 31) 31 i)))
(K (* -1 fx-scale)))]
[(known i t) (cogen-value-$fxsra x i)]
[else
(with-tmp ([i (prm 'sra (T i) (K fx-shift))])
(with-tmp ([i (make-conditional
@ -880,6 +969,7 @@
(K (+ i (- disp-bignum-data record-tag))))
(K 255))
(K fx-shift))]
[(known i t) (cogen-value-$bignum-byte-ref s i)]
[else
(prm 'sll
(prm 'srl ;;; FIXME: bref
@ -950,6 +1040,7 @@
(K (+ (- 7 i) (- disp-flonum-data record-tag))))
(K 255))
(K fx-shift))]
[(known) (error 'translate "$flonum-u8-ref")]
[else (interrupt)])]
[(P s i) (K #t)]
[(E s i) (nop)])
@ -971,6 +1062,7 @@
(prm 'bset/h (T x)
(K (+ (- 7 i) (- disp-flonum-data vector-tag)))
(prm 'sll (T v) (K (- 8 fx-shift))))]
[(known) (error 'translate "$flonum-set!")]
[else (interrupt)])])
(define-primop $fixnum->flonum unsafe
@ -992,6 +1084,13 @@
(if (flonum? v)
(check-flonums (cdr ls) code)
(interrupt))]
[(known x t)
(case (T:flonum? t)
[(yes)
(record-optimization 'check-flonum x)
(check-flonums (cdr ls) code)]
[(no) (interrupt)]
[else (check-flonums (cons x (cdr ls)) code)])]
[else
(check-flonums (cdr ls)
(with-tmp ([x (T (car ls))])
@ -1188,116 +1287,107 @@
(section ;;; generic arithmetic
(define (non-fixnum? x)
(struct-case x
[(constant i) (not (fixnum? i))]
[else #f]))
(define (or* a a*)
(cond
[(null? a*) a]
[(constant? (car a*)) (or* a (cdr a*))]
[else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
(define (assert-fixnums a a*)
(cond
[(constant? a)
(if (null? a*)
(nop)
(assert-fixnums (car a*) (cdr a*)))]
[else
(interrupt-unless
(tag-test (or* (T a) a*) fx-mask fx-tag))]))
(define (or* a a*)
(cond
[(null? a*) a]
[else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
(define (known-fixnum? x)
(struct-case x
[(constant i) (fixnum? i)]
[(known x t)
(case (T:fixnum? t)
[(yes) (record-optimization 'assert-fixnum x) #t]
[else #f])]
[else #f]))
(define (known-non-fixnum? x)
(struct-case x
[(constant i) (not (fixnum? i))]
[(known x t) (eq? (T:fixnum? t) 'no)]
[else #f]))
(let-values ([(fx* others) (partition known-fixnum? (cons a a*))])
(let-values ([(nfx* others) (partition known-non-fixnum? others)])
(cond
[(not (null? nfx*)) (interrupt)]
[(null? others) (nop)]
[else
(interrupt-unless
(tag-test (or* (T (car others)) (cdr others)) fx-mask fx-tag))]))))
(define (fixnum-fold-p op a a*)
(cond
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
[else
(seq*
(assert-fixnums a a*)
(let f ([a a] [a* a*])
(cond
[(null? a*) (K #t)]
[else
(let ([b (car a*)])
(make-conditional
(prm op (T a) (T b))
(f b (cdr a*))
(K #f)))])))]))
(define (fixnum-fold-e a a*)
(cond
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
[else (assert-fixnums a a*)]))
(seq*
(assert-fixnums a a*)
(let f ([a a] [a* a*])
(cond
[(null? a*) (K #t)]
[else
(let ([b (car a*)])
(make-conditional
(prm op (T a) (T b))
(f b (cdr a*))
(K #f)))]))))
(define-primop = safe
[(P) (interrupt)]
[(P a . a*) (fixnum-fold-p '= a a*)]
[(E) (interrupt)]
[(E a . a*) (fixnum-fold-e a a*)])
[(E a . a*) (assert-fixnums a a*)])
(define-primop < safe
[(P) (interrupt)]
[(P a . a*) (fixnum-fold-p '< a a*)]
[(E) (interrupt)]
[(E a . a*) (fixnum-fold-e a a*)])
[(E a . a*) (assert-fixnums a a*)])
(define-primop <= safe
[(P) (interrupt)]
[(P a . a*) (fixnum-fold-p '<= a a*)]
[(E) (interrupt)]
[(E a . a*) (fixnum-fold-e a a*)])
[(E a . a*) (assert-fixnums a a*)])
(define-primop > safe
[(P) (interrupt)]
[(P a . a*) (fixnum-fold-p '> a a*)]
[(E) (interrupt)]
[(E a . a*) (fixnum-fold-e a a*)])
[(E a . a*) (assert-fixnums a a*)])
(define-primop >= safe
[(P) (interrupt)]
[(P a . a*) (fixnum-fold-p '>= a a*)]
[(E) (interrupt)]
[(E a . a*) (fixnum-fold-e a a*)])
[(E a . a*) (assert-fixnums a a*)])
(define-primop - safe
[(V a)
(cond
[(non-fixnum? a) (interrupt)]
[else
(interrupt)
(seq*
(assert-fixnums a '())
(prm 'int-/overflow (K 0) (T a)))])]
(interrupt)
(seq*
(assert-fixnums a '())
(prm 'int-/overflow (K 0) (T a)))]
[(V a . a*)
(cond
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
[else
(interrupt)
(seq*
(assert-fixnums a a*)
(let f ([a (T a)] [a* a*])
(cond
[(null? a*) a]
[else
(f (prm 'int-/overflow a (T (car a*))) (cdr a*))])))])]
(interrupt)
(seq*
(assert-fixnums a a*)
(let f ([a (T a)] [a* a*])
(cond
[(null? a*) a]
[else
(f (prm 'int-/overflow a (T (car a*))) (cdr a*))])))]
[(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
[(E a . a*) (assert-fixnums a a*)])
(define-primop + safe
[(V) (K 0)]
[(V a . a*)
(cond
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
[else
(interrupt)
(seq*
(assert-fixnums a a*)
(let f ([a (T a)] [a* a*])
(cond
[(null? a*) a]
[else
(f (prm 'int+/overflow a (T (car a*))) (cdr a*))])))])]
(interrupt)
(seq*
(assert-fixnums a a*)
(let f ([a (T a)] [a* a*])
(cond
[(null? a*) a]
[else
(f (prm 'int+/overflow a (T (car a*))) (cdr a*))])))]
[(P) (K #t)]
[(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
[(E) (nop)]
@ -1314,27 +1404,34 @@
[(V x) (cogen-value-+ x (K -1))])
(define (cogen-binary-* a b)
(define (cogen-*-non-constants a b)
(interrupt)
(with-tmp ([a (T a)] [b (T b)])
(assert-fixnum a)
(assert-fixnum b)
(prm 'int*/overflow a
(prm 'sra b (K fx-shift)))))
(define (cogen-*-constant a b)
(struct-case a
[(constant ak)
(if (fx? ak)
(begin
(interrupt)
(with-tmp ([b (T b)])
(assert-fixnum b)
(prm 'int*/overflow a b)))
(interrupt))]
[(known x t) (cogen-*-constant x b)]
[else #f]))
(or (cogen-*-constant a b)
(cogen-*-constant b a)
(cogen-*-non-constants a b)))
(define-primop * safe
[(V) (K (fxsll 1 fx-shift))]
[(V a b)
(struct-case a
[(constant ak)
(cond
[(fx? ak)
(with-tmp ([b (T b)])
(assert-fixnum b)
(prm 'int*/overflow b a))]
[else (interrupt)])]
[else
(struct-case b
[(constant bk)
(cond
[(fx? bk)
(with-tmp ([a (T a)])
(assert-fixnum a)
(prm 'int*/overflow a b))]
[else (interrupt)])]
[else (interrupt)])])]
[(V a b) (cogen-binary-* a b)]
[(P) (K #t)]
[(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
[(E) (nop)]
@ -1343,17 +1440,14 @@
(define-primop bitwise-and safe
[(V) (K (fxsll -1 fx-shift))]
[(V a . a*)
(cond
[(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
[else
(interrupt)
(seq*
(assert-fixnums a a*)
(let f ([a (T a)] [a* a*])
(cond
[(null? a*) a]
[else
(f (prm 'logand a (T (car a*))) (cdr a*))])))])]
(interrupt)
(seq*
(assert-fixnums a a*)
(let f ([a (T a)] [a* a*])
(cond
[(null? a*) a]
[else
(f (prm 'logand a (T (car a*))) (cdr a*))])))]
[(P) (K #t)]
[(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
[(E) (nop)]
@ -1367,37 +1461,14 @@
[(V x y) (cogen-value-- x y)])
(define-primop fx* safe
[(V a b)
(struct-case a
[(constant ak)
(cond
[(fx? ak)
(with-tmp ([b (T b)])
(assert-fixnum b)
(prm 'int*/overflow b a))]
[else (interrupt)])]
[else
(struct-case b
[(constant bk)
(cond
[(fx? bk)
(with-tmp ([a (T a)])
(assert-fixnum a)
(prm 'int*/overflow a b))]
[else (interrupt)])]
[else
(with-tmp ([a (T a)] [b (T b)])
(assert-fixnum a)
(assert-fixnum b)
(prm 'int*/overflow
(prm 'sra a (K fx-shift)) b))])])])
[(V a b) (cogen-binary-* a b)])
(define-primop zero? safe
[(P x)
(seq*
(interrupt-unless (cogen-pred-fixnum? x))
(assert-fixnum x)
(cogen-pred-$fxzero? x))]
[(E x) (interrupt-unless (cogen-pred-fixnum? x))])
[(E x) (assert-fixnum x)])
(define-primop fxarithmetic-shift-left safe
@ -1444,7 +1515,6 @@
[else #f])))
(define-primop div safe
[(V x n)
(struct-case n
@ -1459,6 +1529,7 @@
(K fx-shift))))]
[else
(interrupt)])]
[(known) (error 'translate "div")]
[else (interrupt)])])
(define-primop quotient safe
@ -1479,6 +1550,7 @@
(prm 'sra (T x) (K 1))
(K (fxsll -1 fx-shift)))))
(interrupt))]
[(known expr t) (cogen-value-quotient x expr)]
[else (interrupt)])])
/section)
@ -1507,6 +1579,8 @@
(K vector-tag))])
(prm 'mset t (K (- disp-struct-rtd vector-tag)) (T rtd))
t)]
[(known expr t)
(cogen-value-$make-struct rtd expr)]
[else
(with-tmp ([ln (align-code len disp-struct-data)])
(with-tmp ([t (prm 'alloc ln (K vector-tag))])
@ -1594,71 +1668,74 @@
[(P x) (K #t)]
[(E x) (nop)])
(define (non-char? x)
(struct-case x
[(constant i) (not (char? i))]
[else #f]))
(define (assert-chars a a*)
(cond
[(constant? a)
(if (null? a*)
(nop)
(assert-chars (car a*) (cdr a*)))]
[else
(interrupt-unless
(tag-test (or* (T a) a*) char-mask char-tag))]))
(define (or* a a*)
(cond
[(null? a*) a]
[else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
(define (known-char? x)
(struct-case x
[(constant i) (char? i)]
[(known x t) (eq? (T:char? t) 'yes)]
[else #f]))
(define (known-non-char? x)
(struct-case x
[(constant i) (not (char? i))]
[(known x t) (eq? (T:char? t) 'no)]
[else #f]))
(let-values ([(fx* others) (partition known-char? (cons a a*))])
(let-values ([(nfx* others) (partition known-non-char? others)])
(cond
[(not (null? nfx*)) (interrupt)]
[(null? others) (nop)]
[else
(interrupt-unless
(tag-test (or* (T (car others)) (cdr others)) char-mask char-tag))]))))
(define (char-fold-p op a a*)
(cond
[(or (non-char? a) (ormap non-char? a*)) (interrupt)]
[else
(seq*
(assert-chars a a*)
(let f ([a a] [a* a*])
(cond
[(null? a*) (K #t)]
[else
(let ([b (car a*)])
(make-conditional
(prm op (T a) (T b))
(f b (cdr a*))
(K #f)))])))]))
(seq*
(assert-chars a a*)
(let f ([a a] [a* a*])
(cond
[(null? a*) (K #t)]
[else
(let ([b (car a*)])
(make-conditional
(prm op (T a) (T b))
(f b (cdr a*))
(K #f)))]))))
(define (char-fold-e a a*)
(cond
[(or (non-char? a) (ormap non-char? a*)) (interrupt)]
[else (assert-chars a a*)]))
(define-primop char=? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '= a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
[(E a . a*) (assert-chars a a*)])
(define-primop char<? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '< a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
[(E a . a*) (assert-chars a a*)])
(define-primop char<=? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '<= a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
[(E a . a*) (assert-chars a a*)])
(define-primop char>? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '> a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
[(E a . a*) (assert-chars a a*)])
(define-primop char>=? safe
[(P) (interrupt)]
[(P a . a*) (char-fold-p '>= a a*)]
[(E) (interrupt)]
[(E a . a*) (char-fold-e a a*)])
[(E a . a*) (assert-chars a a*)])
/section)
@ -1683,6 +1760,8 @@
(K (+ n (- disp-bytevector-data bytevector-tag)))
(K 0))
s)]
[(known expr t)
(cogen-value-$make-bytevector expr)]
[else
(with-tmp ([s (prm 'alloc
(align-code
@ -1937,6 +2016,8 @@
(K (- disp-string-length string-tag))
(K (* n fx-scale)))
s)]
[(known expr)
(cogen-value-$make-string expr)]
[else
(with-tmp ([s (prm 'alloc
(align-code (T n) disp-string-data)
@ -1973,15 +2054,27 @@
[(P s i) (K #t)]
[(E s i) (nop)])
(define (assert-fixnum x)
(struct-case x
[(constant i)
(if (fixnum? i) (nop) (interrupt))]
[else (interrupt-unless (cogen-pred-fixnum? x))]))
(define assert-fixnum
(case-lambda
[(x)
(struct-case x
[(constant i)
(if (fixnum? i) (nop) (interrupt))]
[(known expr t)
(case (T:fixnum? t)
[(yes) (nop)]
[(no) (interrupt)]
[else (assert-fixnum expr)])]
[else (interrupt-unless (cogen-pred-fixnum? x))])]))
(define (assert-string x)
(struct-case x
[(constant s) (if (string? s) (nop) (interrupt))]
[(known expr t)
(case (T:string? t)
[(yes) (record-optimization 'assert-string x) (nop)]
[(no) (interrupt)]
[else (assert-string expr)])]
[else (interrupt-unless (cogen-pred-string? x))]))
(define-primop string-ref safe
@ -2003,7 +2096,6 @@
(assert-string s)
(interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s))))])
(define-primop $string-set! unsafe
[(E x i c)
(struct-case i

114
scheme/pass-specify-rep.ss
View File

@ -44,7 +44,6 @@
)
(module (specify-representation)
;(import object-representation)
(import primops)
(define-struct PH
(interruptable? p-handler p-handled? v-handler v-handled? e-handler e-handled?))
@ -108,6 +107,14 @@
(prm '!= (make-no-interrupt-call x args) (K bool-f))
(make-shortcut body h)))]
[else (error 'with-interrupt-handler "invalid context" ctxt)])))]))
(define (copy-tag orig new)
(struct-case orig
[(known _ t) (make-known new t)]
[else new]))
(define (remove-tag x)
(struct-case x
[(known expr t) expr]
[else x]))
(define-syntax with-tmp
(lambda (x)
(syntax-case x ()
@ -116,7 +123,7 @@
#'(let ([lhs* rhs*] ...)
(let ([n* (unique-var 'lhs*)] ...)
(make-bind (list n* ...) (list lhs* ...)
(let ([lhs* n*] ...)
(let ([lhs* (copy-tag lhs* n*)] ...)
(seq* b b* ...))))))])))
;;; if ctxt is V:
;;; if cogen-value, then V
@ -140,11 +147,17 @@
(let-values ([(lhs* rhs* arg*) (S* (cdr ls))])
(let ([a (car ls)])
(struct-case a
[(known expr type v)
(let ([tmp (unique-var 'tmp)])
(values (cons tmp lhs*)
(cons (V expr) rhs*)
(cons (make-known tmp type v) arg*)))]
[(known expr type)
(struct-case expr
[(constant i)
;;; erase known tag
(values lhs* rhs* (cons expr arg*))]
[else
;(printf "known ~s ~s\n" type expr)
(let ([tmp (unique-var 'tmp)])
(values (cons tmp lhs*)
(cons (V expr) rhs*)
(cons (make-known tmp type) arg*)))])]
[(constant i)
(values lhs* rhs* (cons a arg*))]
[else
@ -353,7 +366,7 @@
(define (V x) ;;; erase known values
(struct-case x
[(known x type value)
[(known x t)
(unknown-V x)]
[else (unknown-V x)]))
@ -439,43 +452,59 @@
[else (error 'cogen-E "invalid effect expr" x)]))
(define (Function x)
(define (nonproc x)
(with-tmp ([x (V x)])
(make-shortcut
(make-seq
(make-conditional
(tag-test x closure-mask closure-tag)
(prm 'nop)
(prm 'interrupt))
x)
(V (make-funcall (make-primref 'error)
(list (K 'apply) (K "not a procedure") x))))))
(struct-case x
[(primcall op args)
(define (Function x check?)
(define (nonproc x check?)
(cond
[(and (eq? op 'top-level-value)
(= (length args) 1)
(struct-case (car args)
[(constant t)
(and (symbol? t) t)]
[else #f])) =>
(lambda (sym)
(record-symbol-call! sym)
(reset-symbol-proc! sym)
(prm 'mref (T (K sym))
(K (- disp-symbol-record-proc symbol-ptag))))]
[else (nonproc x)])]
[(primref op) (V x)]
[else (nonproc x)]))
[check?
(with-tmp ([x (V x)])
(make-shortcut
(make-seq
(make-conditional
(tag-test x closure-mask closure-tag)
(prm 'nop)
(prm 'interrupt))
x)
(V (make-funcall (make-primref 'error)
(list (K 'apply) (K "not a procedure") x)))))]
[else
(V x)]))
(struct-case x
[(primcall op args)
(cond
[(and (eq? op 'top-level-value)
(= (length args) 1)
(let f ([x (car args)])
(struct-case x
[(constant x)
(and (symbol? x) x)]
[(known x t) (f x)]
[else #f]))) =>
(lambda (sym)
(reset-symbol-proc! sym)
(prm 'mref (T (K sym))
(K (- disp-symbol-record-proc symbol-ptag))))]
[else (nonproc x check?)])]
[(primref op) (V x)]
[(known x t v)
(cond
[(eq? (T:procedure? t) 'yes)
;(record-optimization 'procedure x)
(Function x #f)]
[else (Function x check?)])]
[else (nonproc x check?)]))
(Function x #t))
(define encountered-symbol-calls '())
(define (record-symbol-call! x)
(unless (memq x encountered-symbol-calls)
(set! encountered-symbol-calls
(cons x encountered-symbol-calls))))
(define record-optimization^
(let ([h (make-eq-hashtable)])
(lambda (what expr)
(let ([n (hashtable-ref h what 0)])
(hashtable-set! h what (+ n 1))
(printf "optimize ~a[~s]: ~s\n" what n (unparse expr))))))
(define-syntax record-optimization
(syntax-rules ()
[(_ what expr) (void)]))
;;;========================================================================
;;;
@ -491,7 +520,8 @@
(struct-case x
[(var) x]
[(constant i) (constant-rep x)]
[(known expr type val) (T expr)]
[(known expr type)
(make-known (T expr) type)]
[else (error 'cogen-T "invalid" (unparse x))]))
(define (ClambdaCase x)