554 lines
19 KiB
Scheme
554 lines
19 KiB
Scheme
;;; 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/>.
|
|
|
|
|
|
;(module primops (primop? cogen-primop)
|
|
; (define (primop? x) #f)
|
|
; (define cogen-primop (lambda args (error 'cogen-primop "not yet"))))
|
|
;
|
|
;#!eof
|
|
|
|
;(define-syntax export-all-module
|
|
; (syntax-rules (define)
|
|
; [(_ M (define name* v*) ...)
|
|
; (module M (name* ...)
|
|
; (define name* v*) ...)]))
|
|
;
|
|
;(export-all-module object-representation
|
|
; (define fixnum-scale 4)
|
|
; (define fixnum-shift 2)
|
|
; (define fixnum-tag 0)
|
|
; (define fixnum-mask 3))
|
|
|
|
(module primops (primop? get-primop set-primop!)
|
|
(define cookie (gensym))
|
|
(define (primop? x)
|
|
(and (getprop x cookie) #t))
|
|
(define (get-primop x)
|
|
(or (getprop x cookie)
|
|
(error 'getprimop "not a primitive" x)))
|
|
(define (set-primop! x v)
|
|
(putprop x cookie v))
|
|
)
|
|
|
|
(module (specify-representation)
|
|
(import primops)
|
|
(define-struct PH
|
|
(interruptable? p-handler p-handled? v-handler v-handled? e-handler e-handled?))
|
|
(define interrupt-handler
|
|
(make-parameter (lambda () (error 'interrupt-handler "uninitialized"))))
|
|
(define (interrupt)
|
|
((interrupt-handler))
|
|
(prm 'interrupt))
|
|
(define (primop-interrupt-handler x)
|
|
(case x
|
|
[(fx+) 'error@fx+]
|
|
[(fx-) 'error@fx-]
|
|
[(fx*) 'error@fx*]
|
|
[(add1) 'error@add1]
|
|
[(sub1) 'error@sub1]
|
|
[(fxadd1) 'error@fxadd1]
|
|
[(fxsub1) 'error@fxsub1]
|
|
[(fxarithmetic-shift-left) 'error@fxarithmetic-shift-left]
|
|
[else x]))
|
|
(define (make-interrupt-call op args)
|
|
(make-funcall
|
|
(V (make-primref (primop-interrupt-handler op)))
|
|
args))
|
|
(define (make-no-interrupt-call op args)
|
|
(make-funcall (V (make-primref op)) args))
|
|
(define (with-interrupt-handler p x ctxt args k)
|
|
(cond
|
|
[(not (PH-interruptable? p))
|
|
(parameterize ([interrupt-handler
|
|
(lambda ()
|
|
(error 'cogen "uninterruptable"
|
|
x args ctxt))])
|
|
(k))]
|
|
[else
|
|
(let ([interrupted? #f])
|
|
(let ([body
|
|
(parameterize ([interrupt-handler
|
|
(lambda () (set! interrupted? #t))])
|
|
(k))])
|
|
(cond
|
|
[(not interrupted?) body]
|
|
[(eq? ctxt 'V)
|
|
(let ([h (make-interrupt-call x args)])
|
|
(if (struct-case body
|
|
[(primcall op) (eq? op 'interrupt)]
|
|
[else #f])
|
|
(make-no-interrupt-call x args)
|
|
(make-shortcut body h)))]
|
|
[(eq? ctxt 'E)
|
|
(let ([h (make-interrupt-call x args)])
|
|
(if (struct-case body
|
|
[(primcall op) (eq? op 'interrupt)]
|
|
[else #f])
|
|
(make-no-interrupt-call x args)
|
|
(make-shortcut body h)))]
|
|
[(eq? ctxt 'P)
|
|
(let ([h (prm '!= (make-interrupt-call x args) (K bool-f))])
|
|
(if (struct-case body
|
|
[(primcall op) (eq? op 'interrupt)]
|
|
[else #f])
|
|
(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 ()
|
|
[(_ ([lhs* rhs*] ...) b b* ...)
|
|
(with-syntax ([(n* ...) (generate-temporaries #'(lhs* ...))])
|
|
#'(let ([lhs* rhs*] ...)
|
|
(let ([n* (unique-var 'lhs*)] ...)
|
|
(make-bind (list n* ...) (list lhs* ...)
|
|
(let ([lhs* (copy-tag lhs* n*)] ...)
|
|
(seq* b b* ...))))))])))
|
|
;;; if ctxt is V:
|
|
;;; if cogen-value, then V
|
|
;;; if cogen-pred, then (if P #f #t)
|
|
;;; if cogen-effect, then (seq E (void))
|
|
;;;
|
|
;;; if ctxt is P:
|
|
;;; if cogen-pred, then P
|
|
;;; if cogen-value, then (!= V #f)
|
|
;;; if cogen-effect, then (seq E #t)
|
|
;;;
|
|
;;; if ctxt is E:
|
|
;;; if cogen-effect, then E
|
|
;;; if cogen-value, then (let ([tmp V]) (nop))
|
|
;;; if cogen-pred, then (if P (nop) (nop))
|
|
(define (simplify* args k)
|
|
(define (S* ls)
|
|
(cond
|
|
[(null? ls) (values '() '() '())]
|
|
[else
|
|
(let-values ([(lhs* rhs* arg*) (S* (cdr ls))])
|
|
(let ([a (car ls)])
|
|
(struct-case a
|
|
[(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
|
|
(let ([t (unique-var 'tmp)])
|
|
(values (cons t lhs*) (cons (V a) rhs*) (cons t arg*)))])))]))
|
|
(let-values ([(lhs* rhs* args) (S* args)])
|
|
(cond
|
|
[(null? lhs*) (k args)]
|
|
[else
|
|
(make-bind lhs* rhs* (k args))])))
|
|
(define (cogen-primop x ctxt args)
|
|
(define (interrupt? x)
|
|
(struct-case x
|
|
[(primcall x) (eq? x 'interrupt)]
|
|
[else #f]))
|
|
(let ([p (get-primop x)])
|
|
(simplify* args
|
|
(lambda (args)
|
|
(with-interrupt-handler p x ctxt (map T args)
|
|
(lambda ()
|
|
(case ctxt
|
|
[(P)
|
|
(cond
|
|
[(PH-p-handled? p)
|
|
(apply (PH-p-handler p) args)]
|
|
[(PH-v-handled? p)
|
|
(let ([e (apply (PH-v-handler p) args)])
|
|
(if (interrupt? e) e (prm '!= e (K bool-f))))]
|
|
[(PH-e-handled? p)
|
|
(let ([e (apply (PH-e-handler p) args)])
|
|
(if (interrupt? e) e (make-seq e (K #t))))]
|
|
[else (error 'cogen-primop "not handled" x)])]
|
|
[(V)
|
|
(cond
|
|
[(PH-v-handled? p)
|
|
(apply (PH-v-handler p) args)]
|
|
[(PH-p-handled? p)
|
|
(let ([e (apply (PH-p-handler p) args)])
|
|
(if (interrupt? e)
|
|
e
|
|
(make-conditional e (K bool-t) (K bool-f))))]
|
|
[(PH-e-handled? p)
|
|
(let ([e (apply (PH-e-handler p) args)])
|
|
(if (interrupt? e) e (make-seq e (K void-object))))]
|
|
[else (error 'cogen-primop "not handled" x)])]
|
|
[(E)
|
|
(cond
|
|
[(PH-e-handled? p)
|
|
(apply (PH-e-handler p) args)]
|
|
[(PH-p-handled? p)
|
|
(let ([e (apply (PH-p-handler p) args)])
|
|
(if (interrupt? e)
|
|
e
|
|
(make-conditional e (prm 'nop) (prm 'nop))))]
|
|
[(PH-v-handled? p)
|
|
(let ([e (apply (PH-v-handler p) args)])
|
|
(if (interrupt? e)
|
|
e
|
|
(with-tmp ([t e]) (prm 'nop))))]
|
|
[else (error 'cogen-primop "not handled" x)])]
|
|
[else
|
|
(error 'cogen-primop "invalid context" ctxt)])))))))
|
|
|
|
(define-syntax define-primop
|
|
(lambda (x)
|
|
(define (cogen-name stx name suffix)
|
|
(datum->syntax stx
|
|
(string->symbol
|
|
(format "cogen-~a-~a"
|
|
suffix
|
|
(syntax->datum name)))))
|
|
(define (generate-handler name ctxt case*)
|
|
(define (filter-cases case*)
|
|
(syntax-case case* ()
|
|
[() '()]
|
|
[([(c . arg*) b b* ...] . rest)
|
|
(free-identifier=? #'c ctxt)
|
|
(cons #'[arg* b b* ...] (filter-cases #'rest))]
|
|
[(c . rest) (filter-cases #'rest)]))
|
|
(let ([case* (filter-cases case*)])
|
|
(with-syntax ([ctxt ctxt] [name name]
|
|
[(case* ...) case*]
|
|
[handled? (not (null? case*))])
|
|
#'[(case-lambda
|
|
case* ...
|
|
[args (interrupt)])
|
|
handled?])))
|
|
(syntax-case x ()
|
|
[(stx name int? case* ...)
|
|
(with-syntax ([cogen-p (cogen-name #'stx #'name "pred")]
|
|
[cogen-e (cogen-name #'stx #'name "effect")]
|
|
[cogen-v (cogen-name #'stx #'name "value")]
|
|
[interruptable?
|
|
(syntax-case #'int? (safe unsafe)
|
|
[safe #t] [unsafe #f])]
|
|
[(p-handler phandled?)
|
|
(generate-handler #'name #'P #'(case* ...))]
|
|
[(v-handler vhandled?)
|
|
(generate-handler #'name #'V #'(case* ...))]
|
|
[(e-handler ehandled?)
|
|
(generate-handler #'name #'E #'(case* ...))])
|
|
#'(begin
|
|
(define cogen-p p-handler)
|
|
(define cogen-v v-handler)
|
|
(define cogen-e e-handler)
|
|
(module ()
|
|
(set-primop! 'name
|
|
(make-PH interruptable?
|
|
cogen-p phandled?
|
|
cogen-v vhandled?
|
|
cogen-e ehandled?)))))])))
|
|
|
|
|
|
(define (handle-fix lhs* rhs* body)
|
|
(define (closure-size x)
|
|
(struct-case x
|
|
[(closure code free*)
|
|
(if (null? free*)
|
|
0
|
|
(align (+ disp-closure-data
|
|
(* (length free*) wordsize))))]))
|
|
(define (partition p? lhs* rhs*)
|
|
(cond
|
|
[(null? lhs*) (values '() '() '() '())]
|
|
[else
|
|
(let-values ([(a* b* c* d*)
|
|
(partition p? (cdr lhs*) (cdr rhs*))]
|
|
[(x y) (values (car lhs*) (car rhs*))])
|
|
(cond
|
|
[(p? x y)
|
|
(values (cons x a*) (cons y b*) c* d*)]
|
|
[else
|
|
(values a* b* (cons x c*) (cons y d*))]))]))
|
|
(define (combinator? lhs rhs)
|
|
(struct-case rhs
|
|
[(closure code free*) (null? free*)]))
|
|
(define (sum n* n)
|
|
(cond
|
|
[(null? n*) n]
|
|
[else (sum (cdr n*) (+ n (car n*)))]))
|
|
(define (adders lhs n n*)
|
|
(cond
|
|
[(null? n*) '()]
|
|
[else
|
|
(cons (prm 'int+ lhs (K n))
|
|
(adders lhs (+ n (car n*)) (cdr n*)))]))
|
|
(define (build-closures lhs* rhs* body)
|
|
(let ([lhs (car lhs*)] [rhs (car rhs*)]
|
|
[lhs* (cdr lhs*)] [rhs* (cdr rhs*)])
|
|
(let ([n (closure-size rhs)]
|
|
[n* (map closure-size rhs*)])
|
|
(make-bind (list lhs)
|
|
(list (prm 'alloc
|
|
(K (sum n* n))
|
|
(K closure-tag)))
|
|
(make-bind lhs* (adders lhs n n*)
|
|
body)))))
|
|
(define (build-setters lhs* rhs* body)
|
|
(define (build-setter lhs rhs body)
|
|
(struct-case rhs
|
|
[(closure code free*)
|
|
(make-seq
|
|
(prm 'mset lhs
|
|
(K (- disp-closure-code closure-tag))
|
|
(V code))
|
|
(let f ([ls free*]
|
|
[i (- disp-closure-data closure-tag)])
|
|
(cond
|
|
[(null? ls) body]
|
|
[else
|
|
(make-seq
|
|
(prm 'mset lhs (K i) (V (car ls)))
|
|
(f (cdr ls) (+ i wordsize)))])))]))
|
|
(cond
|
|
[(null? lhs*) body]
|
|
[else
|
|
(build-setter (car lhs*) (car rhs*)
|
|
(build-setters (cdr lhs*) (cdr rhs*) body))]))
|
|
(let-values ([(flhs* frhs* clhs* crhs*)
|
|
(partition combinator? lhs* rhs*)])
|
|
(cond
|
|
[(null? clhs*) (make-bind flhs* (map V frhs*) body)]
|
|
[(null? flhs*)
|
|
(build-closures clhs* crhs*
|
|
(build-setters clhs* crhs* body))]
|
|
[else
|
|
(make-bind flhs* (map V frhs*)
|
|
(build-closures clhs* crhs*
|
|
(build-setters clhs* crhs* body)))])))
|
|
|
|
|
|
(define (constant-rep x)
|
|
(let ([c (constant-value x)])
|
|
(cond
|
|
[(fx? c) (make-constant (* c fx-scale))]
|
|
[(boolean? c) (make-constant (if c bool-t bool-f))]
|
|
[(eq? c (void)) (make-constant void-object)]
|
|
[(bwp-object? c) (make-constant bwp-object)]
|
|
[(char? c) (make-constant
|
|
(fxlogor char-tag
|
|
(fxsll (char->integer c) char-shift)))]
|
|
[(null? c) (make-constant nil)]
|
|
[(eof-object? c) (make-constant eof)]
|
|
[(object? c) (error 'constant-rep "double-wrap")]
|
|
[else (make-constant (make-object c))])))
|
|
|
|
(define (V x) ;;; erase known values
|
|
(struct-case x
|
|
[(known x t)
|
|
(unknown-V x)]
|
|
[else (unknown-V x)]))
|
|
|
|
(define (unknown-V x)
|
|
(struct-case x
|
|
[(constant) (constant-rep x)]
|
|
[(var) x]
|
|
[(primref name)
|
|
(prm 'mref
|
|
(K (make-object (primref->symbol name)))
|
|
(K (- disp-symbol-record-value symbol-ptag)))]
|
|
[(code-loc) (make-constant x)]
|
|
[(closure) (make-constant x)]
|
|
[(bind lhs* rhs* body)
|
|
(make-bind lhs* (map V rhs*) (V body))]
|
|
[(fix lhs* rhs* body)
|
|
(handle-fix lhs* rhs* (V body))]
|
|
[(conditional e0 e1 e2)
|
|
(make-conditional (P e0) (V e1) (V e2))]
|
|
[(seq e0 e1)
|
|
(make-seq (E e0) (V e1))]
|
|
[(primcall op arg*)
|
|
(cogen-primop op 'V arg*)]
|
|
[(forcall op arg*)
|
|
(make-forcall op (map V arg*))]
|
|
[(funcall rator arg*)
|
|
(make-funcall (Function rator) (map V arg*))]
|
|
[(jmpcall label rator arg*)
|
|
(make-jmpcall label (V rator) (map V arg*))]
|
|
[else (error 'cogen-V "invalid value expr" x)]))
|
|
|
|
(define (P x)
|
|
(struct-case x
|
|
[(constant c) (if c (K #t) (K #f))]
|
|
[(primref) (K #t)]
|
|
[(code-loc) (K #t)]
|
|
[(closure) (K #t)]
|
|
[(bind lhs* rhs* body)
|
|
(make-bind lhs* (map V rhs*) (P body))]
|
|
[(conditional e0 e1 e2)
|
|
(make-conditional (P e0) (P e1) (P e2))]
|
|
[(seq e0 e1)
|
|
(make-seq (E e0) (P e1))]
|
|
[(fix lhs* rhs* body)
|
|
(handle-fix lhs* rhs* (P body))]
|
|
[(primcall op arg*)
|
|
(cogen-primop op 'P arg*)]
|
|
[(var) (prm '!= (V x) (V (K #f)))]
|
|
[(funcall) (prm '!= (V x) (V (K #f)))]
|
|
[(jmpcall) (prm '!= (V x) (V (K #f)))]
|
|
[(forcall) (prm '!= (V x) (V (K #f)))]
|
|
[(known expr type)
|
|
;;; FIXME: suboptimal
|
|
(P expr)]
|
|
[else (error 'cogen-P "invalid pred expr" x)]))
|
|
|
|
(define (E x)
|
|
(struct-case x
|
|
[(constant) (nop)]
|
|
[(var) (nop)]
|
|
[(primref) (nop)]
|
|
[(code-loc) (nop)]
|
|
[(closure) (nop)]
|
|
[(bind lhs* rhs* body)
|
|
(make-bind lhs* (map V rhs*) (E body))]
|
|
[(conditional e0 e1 e2)
|
|
(make-conditional (P e0) (E e1) (E e2))]
|
|
[(seq e0 e1)
|
|
(make-seq (E e0) (E e1))]
|
|
[(fix lhs* rhs* body)
|
|
(handle-fix lhs* rhs* (E body))]
|
|
[(primcall op arg*)
|
|
(cogen-primop op 'E arg*)]
|
|
[(forcall op arg*)
|
|
(make-forcall op (map V arg*))]
|
|
[(funcall rator arg*)
|
|
(make-funcall (Function rator) (map V arg*))]
|
|
[(jmpcall label rator arg*)
|
|
(make-jmpcall label (V rator) (map V arg*))]
|
|
[(known expr type)
|
|
;;; FIXME: suboptimal
|
|
(E expr)]
|
|
[else (error 'cogen-E "invalid effect expr" x)]))
|
|
|
|
(define (Function x)
|
|
(define (Function x check?)
|
|
(define (nonproc x check?)
|
|
(cond
|
|
[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)
|
|
(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 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)]))
|
|
|
|
;;;========================================================================
|
|
;;;
|
|
(define (interrupt-unless x)
|
|
(make-conditional x (prm 'nop) (interrupt)))
|
|
(define (interrupt-when x)
|
|
(make-conditional x (interrupt) (prm 'nop)))
|
|
(define (interrupt-unless-fixnum x)
|
|
(interrupt-unless (tag-test x fx-mask fx-tag)))
|
|
|
|
|
|
(define (T x)
|
|
(struct-case x
|
|
[(var) x]
|
|
[(constant i) (constant-rep x)]
|
|
[(known expr type)
|
|
(make-known (T expr) type)]
|
|
[else (error 'cogen-T "invalid" (unparse x))]))
|
|
|
|
(define (ClambdaCase x)
|
|
(struct-case x
|
|
[(clambda-case info body)
|
|
(make-clambda-case info (V body))]
|
|
[else (error 'specify-rep "invalid clambda-case" x)]))
|
|
;;;
|
|
(define (Clambda x)
|
|
(struct-case x
|
|
[(clambda label case* cp free* name)
|
|
(make-clambda label
|
|
(map ClambdaCase case*)
|
|
cp free* name)]
|
|
[else (error 'specify-rep "invalid clambda" x)]))
|
|
;;;
|
|
(define (Program x)
|
|
(struct-case x
|
|
[(codes code* body)
|
|
(let ([code* (map Clambda code*)]
|
|
[body (V body)])
|
|
(make-codes code* body))]
|
|
[else (error 'specify-rep "invalid program" x)]))
|
|
|
|
(define (specify-representation x)
|
|
(let ([x (Program x)])
|
|
x))
|
|
|
|
(include-src "pass-specify-rep-primops.ss"))
|