WIP on tag analysis, annotations, and utilization.
This commit is contained in:
Abdulaziz Ghuloum
parent
d73dfd1287
commit
579b823f44
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -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)))]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
'(
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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? | ||||