714 lines
30 KiB
Scheme
714 lines
30 KiB
Scheme
|
;;; interpret.ss
|
||
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
;;; TODO
|
||
|
|
;;; - recognize direct close calls in ip2 to avoid creation of closure
|
||
|
|
;;; (but not closure pointer) and overhead of call
|
||
|
|
;;; - handle let & letrec better
|
||
|
|
;;; - use arg regs when available
|
||
|
|
;;; - wire up letrec closures, then treat like let (good luck)
|
||
|
|
;;; - optimize direct calls when no free vars
|
||
|
|
;;; - since closure is just code in this case, can wire it in directly
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(import (nanopass))
|
||
|
|
(include "base-lang.ss")
|
||
|
|
(include "expand-lang.ss")
|
||
|
|
|
||
|
|
(define-record-type c-var
|
||
|
|
(fields (immutable id) (immutable parent) (mutable index) (mutable loc))
|
||
|
|
(nongenerative)
|
||
|
|
(sealed #t)
|
||
|
|
(protocol
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (id parent)
|
||
|
|
(new id parent #f #f)))))
|
||
|
|
|
||
|
|
(define list-of-c-var?
|
||
|
|
(lambda (x)
|
||
|
|
(and (list? x) (andmap c-var? x))))
|
||
|
|
|
||
|
|
(define-language Linterp
|
||
|
|
(extends Lsrc)
|
||
|
|
(terminals
|
||
|
|
(- ($prelex (x)))
|
||
|
|
(+ (c-var (x))
|
||
|
|
(list-of-c-var (free))))
|
||
|
|
(Expr (e body rtd-expr)
|
||
|
|
(- (case-lambda preinfo cl ...)
|
||
|
|
(call preinfo e0 e1 ...)
|
||
|
|
(moi)
|
||
|
|
(pariah)
|
||
|
|
(ref maybe-src x)
|
||
|
|
(set! maybe-src x e)
|
||
|
|
(profile src))
|
||
|
|
(+ x
|
||
|
|
(close free cl ...)
|
||
|
|
(call e e* ...)
|
||
|
|
(set! x e))))
|
||
|
|
|
||
|
|
(define ip1
|
||
|
|
(let ()
|
||
|
|
(define-record-type c-env
|
||
|
|
(fields (immutable prev) (mutable vars))
|
||
|
|
(nongenerative)
|
||
|
|
(sealed #t)
|
||
|
|
(protocol
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (prev)
|
||
|
|
(new prev '())))))
|
||
|
|
|
||
|
|
(define-pass ip1 : Lsrc (ir) -> Linterp ()
|
||
|
|
(definitions
|
||
|
|
(define ip1-lambda
|
||
|
|
(lambda (clauses env)
|
||
|
|
(let ([env (make-c-env env)])
|
||
|
|
(let ([bodies
|
||
|
|
(map (lambda (clause)
|
||
|
|
(nanopass-case (Lsrc CaseLambdaClause) clause
|
||
|
|
[(clause (,x* ...) ,interface ,body)
|
||
|
|
(with-vars (vars x* env)
|
||
|
|
(with-output-language (Linterp CaseLambdaClause)
|
||
|
|
(let ([body (Expr body env)])
|
||
|
|
`(clause (,vars ...) ,interface ,body))))]
|
||
|
|
[else (errorf 'ip1-lambda "found something unexpected ~s\n" clause)]))
|
||
|
|
clauses)])
|
||
|
|
(with-output-language (Linterp Expr)
|
||
|
|
`(close ,(ip1-free env) ,bodies ...))))))
|
||
|
|
(define ip1-letrec
|
||
|
|
(lambda (ids vals body env)
|
||
|
|
(with-output-language (Lsrc Expr)
|
||
|
|
(define build-let
|
||
|
|
(lambda (ids vals body)
|
||
|
|
(if (null? ids)
|
||
|
|
body
|
||
|
|
`(call ,(make-preinfo)
|
||
|
|
(case-lambda ,(make-preinfo-lambda)
|
||
|
|
(clause (,ids ...) ,(length ids) ,body))
|
||
|
|
,vals ...))))
|
||
|
|
(Expr (if (null? ids)
|
||
|
|
body
|
||
|
|
(build-let ids (map (lambda (x) `(quote ,(void))) ids)
|
||
|
|
(fold-left (lambda (body id val)
|
||
|
|
(set-prelex-assigned! id #t)
|
||
|
|
`(seq (set! #f ,id ,val) ,body))
|
||
|
|
body ids vals)))
|
||
|
|
env)))))
|
||
|
|
(Expr : Expr (ir [env #f]) -> Expr ()
|
||
|
|
[(ref ,maybe-src ,x) (ip1-lookup-lexical x env)]
|
||
|
|
[(case-lambda ,preinfo ,cl* ...) (ip1-lambda cl* env)]
|
||
|
|
[(call ,preinfo ,[e] ,[e*] ...) `(call ,e ,e* ...)]
|
||
|
|
[(set! ,maybe-src ,x ,[e]) `(set! ,(ip1-lookup-lexical x env) ,e)]
|
||
|
|
[(letrec ([,x* ,e*] ...) ,body) (ip1-letrec x* e* body env)]
|
||
|
|
[(seq ,[e1] ,[e2])
|
||
|
|
(nanopass-case (Linterp Expr) e1
|
||
|
|
[(quote ,d) e2]
|
||
|
|
[else `(seq ,e1 ,e2)])]
|
||
|
|
[(moi) `(quote #f)]
|
||
|
|
[(pariah) `(quote ,(void))]
|
||
|
|
[(profile ,src) `(quote ,(void))]))
|
||
|
|
|
||
|
|
;;; When we create a lex from a prelex, we replace the name field of
|
||
|
|
;;; the prelex id with an initial mapping from environment to the lex
|
||
|
|
;;; var corresponding to the prelex in the environment. This mapping is
|
||
|
|
;;; augmented by lookup-lexical (for references through rebind-free
|
||
|
|
;;; environments) and trimmed by maybe-free.
|
||
|
|
|
||
|
|
(define-syntax with-var
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ (var idexp env) e1 e2 ...)
|
||
|
|
(let ((id idexp))
|
||
|
|
(let ((name (prelex-name id)))
|
||
|
|
(let ((var (make-c-var id #f)))
|
||
|
|
(prelex-name-set! id (list (cons env var)))
|
||
|
|
(let ((tmp (begin e1 e2 ...)))
|
||
|
|
; restore name to leave prelex undamaged; this is necessary at
|
||
|
|
; present because syntax objects may contain the same prelexes
|
||
|
|
; that arrive here as bound variables
|
||
|
|
(prelex-name-set! id name)
|
||
|
|
tmp)))))))
|
||
|
|
|
||
|
|
(define-syntax with-vars
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ (vars idsexp env) e1 e2 ...)
|
||
|
|
(let f ((ids (reverse idsexp)) (vars '()))
|
||
|
|
(if (null? ids)
|
||
|
|
(begin e1 e2 ...)
|
||
|
|
(with-var (var (car ids) env)
|
||
|
|
(f (cdr ids) (cons var vars))))))))
|
||
|
|
|
||
|
|
(define ip1-free
|
||
|
|
(lambda (e)
|
||
|
|
(map (lambda (id)
|
||
|
|
(let ((ls (prelex-name id)))
|
||
|
|
(prelex-name-set! id (cdr ls))
|
||
|
|
(cdar ls)))
|
||
|
|
(c-env-vars e))))
|
||
|
|
|
||
|
|
(define ip1-lookup-lexical
|
||
|
|
(lambda (id e)
|
||
|
|
(let ((ls (prelex-name id)))
|
||
|
|
(if (eq? (caar ls) e)
|
||
|
|
(cdar ls)
|
||
|
|
(let ((y (ip1-lookup-lexical id (c-env-prev e))))
|
||
|
|
(let ([z (make-c-var id y)])
|
||
|
|
(c-env-vars-set! e (cons id (c-env-vars e)))
|
||
|
|
(prelex-name-set! id (cons (cons e z) (prelex-name id)))
|
||
|
|
z))))))
|
||
|
|
|
||
|
|
(lambda (x) (ip1 x))))
|
||
|
|
|
||
|
|
(define-syntactic-monad $rt a0 a1 fp cp)
|
||
|
|
|
||
|
|
(module (ip2)
|
||
|
|
(define unexpected-loc
|
||
|
|
(lambda (loc)
|
||
|
|
($oops 'interpret-internal "unexpected loc ~s" loc)))
|
||
|
|
|
||
|
|
(define ip2
|
||
|
|
(lambda (x)
|
||
|
|
(define unexpected-record
|
||
|
|
(lambda (x)
|
||
|
|
($oops 'interpret-internal "unexpected record ~s" x)))
|
||
|
|
(define non-procedure
|
||
|
|
(lambda (x)
|
||
|
|
($oops #f "attempt to apply non-procedure ~s" x)))
|
||
|
|
(define unbound-or-non-procedure
|
||
|
|
(lambda (sym x)
|
||
|
|
(if ($unbound-object? x)
|
||
|
|
($oops #f "variable ~:s is not bound" sym)
|
||
|
|
(non-procedure x))))
|
||
|
|
(define-syntax docall-sym
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-case x ()
|
||
|
|
[(_ sym e1 ...)
|
||
|
|
(with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))])
|
||
|
|
#'($rt lambda ()
|
||
|
|
(let ([t0 (#3%$top-level-value sym)] [t1 ($rt e1)] ...)
|
||
|
|
(unless (procedure? t0) (unbound-or-non-procedure sym t0))
|
||
|
|
(t0 t1 ...))))])))
|
||
|
|
(define-syntax docall
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-case x ()
|
||
|
|
[(_ e0 e1 ...)
|
||
|
|
(with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))])
|
||
|
|
#'($rt lambda ()
|
||
|
|
(let ([t0 e0] [t1 ($rt e1)] ...)
|
||
|
|
(unless (procedure? t0) (non-procedure t0))
|
||
|
|
(t0 t1 ...))))])))
|
||
|
|
(define-syntax docallx
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-case x ()
|
||
|
|
[(_ e0 e1 ...)
|
||
|
|
(with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))])
|
||
|
|
#'($rt lambda ()
|
||
|
|
(let ([t0 ($rt e0)] [t1 ($rt e1)] ...)
|
||
|
|
(unless (procedure? t0) (non-procedure t0))
|
||
|
|
(t0 t1 ...))))])))
|
||
|
|
(define ip2-fat-call
|
||
|
|
(lambda (fun args)
|
||
|
|
(let ((args (reverse args)))
|
||
|
|
($rt lambda ()
|
||
|
|
(let ((fun ($rt fun)))
|
||
|
|
(let loop ([args args] [vals '()])
|
||
|
|
(if (null? args)
|
||
|
|
(begin
|
||
|
|
(unless (procedure? fun) (non-procedure fun))
|
||
|
|
(apply fun vals))
|
||
|
|
(loop (cdr args) (cons ($rt (car args)) vals)))))))))
|
||
|
|
(nanopass-case (Linterp Expr) x
|
||
|
|
[,x
|
||
|
|
(let ((loc (c-var-loc x)) (i (c-var-index x)))
|
||
|
|
(if (prelex-assigned (c-var-id x))
|
||
|
|
(case loc
|
||
|
|
[(a0) ($rt lambda () (car a0))]
|
||
|
|
[(a1) ($rt lambda () (car a1))]
|
||
|
|
[(fp) ($rt lambda () (car fp))]
|
||
|
|
[(cp) ($rt lambda () (car cp))]
|
||
|
|
[(frame) ($rt lambda () (car (list-ref fp i)))]
|
||
|
|
[(frame-rest) ($rt lambda () (car (list-tail fp i)))]
|
||
|
|
[(closure) ($rt lambda () (car (vector-ref cp i)))]
|
||
|
|
[else (unexpected-loc loc)])
|
||
|
|
(case loc
|
||
|
|
[(a0) ($rt lambda () a0)]
|
||
|
|
[(a1) ($rt lambda () a1)]
|
||
|
|
[(fp) ($rt lambda () fp)]
|
||
|
|
[(cp) ($rt lambda () cp)]
|
||
|
|
[(frame) ($rt lambda () (list-ref fp i))]
|
||
|
|
[(frame-rest) ($rt lambda () (list-tail fp i))]
|
||
|
|
[(closure) ($rt lambda () (vector-ref cp i))]
|
||
|
|
[else (unexpected-loc loc)])))]
|
||
|
|
[,pr (let ((fun ($top-level-value (primref-name pr))))
|
||
|
|
($rt lambda () fun))]
|
||
|
|
[(quote ,d) ($rt lambda () d)]
|
||
|
|
[(close ,free ,cl* ...)
|
||
|
|
(unless (null? free)
|
||
|
|
(if (null? (cdr free))
|
||
|
|
(c-var-loc-set! (car free) 'cp)
|
||
|
|
(let loop ((free free) (i 0))
|
||
|
|
(unless (null? free)
|
||
|
|
(c-var-loc-set! (car free) 'closure)
|
||
|
|
(c-var-index-set! (car free) i)
|
||
|
|
(loop (cdr free) (fx+ i 1))))))
|
||
|
|
(or (and (not (null? cl*))
|
||
|
|
(null? (cdr cl*))
|
||
|
|
(nanopass-case (Linterp CaseLambdaClause) (car cl*)
|
||
|
|
[(clause (,x* ...) ,interface ,body)
|
||
|
|
(if (null? free)
|
||
|
|
(case interface
|
||
|
|
[(0)
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda ()
|
||
|
|
($rt body ([a0 0] [a1 0] [fp 0] [cp 0])))))]
|
||
|
|
[(1)
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0)
|
||
|
|
($rt body ([a1 0] [fp 0] [cp 0])))))]
|
||
|
|
[(2)
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0 a1)
|
||
|
|
($rt body ([fp 0] [cp 0])))))]
|
||
|
|
[(3)
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0 a1 fp)
|
||
|
|
($rt body ([cp 0])))))]
|
||
|
|
[(4)
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0 a1 fp cp)
|
||
|
|
($rt body))))]
|
||
|
|
[else #f])
|
||
|
|
(case interface
|
||
|
|
[(0)
|
||
|
|
(ip2-closure free
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda ()
|
||
|
|
($rt body ([a0 0] [a1 0] [fp 0]))))))]
|
||
|
|
[(1)
|
||
|
|
(ip2-closure free
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0)
|
||
|
|
($rt body ([a1 0] [fp 0]))))))]
|
||
|
|
[(2)
|
||
|
|
(ip2-closure free
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0 a1)
|
||
|
|
($rt body ([fp 0]))))))]
|
||
|
|
[(3)
|
||
|
|
(ip2-closure free
|
||
|
|
(let ((body (ip2-body body x* '(a0 a1 fp) #f)))
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0 a1 fp)
|
||
|
|
($rt body)))))]
|
||
|
|
[else #f]))]))
|
||
|
|
; we could use cp if no closure; we could use fp if max interface
|
||
|
|
; is small enough. we don't bother with either presently.
|
||
|
|
(let ((m (let min? ((cl* cl*) (m (length '(a0 a1))))
|
||
|
|
(if (null? cl*)
|
||
|
|
m
|
||
|
|
(nanopass-case (Linterp CaseLambdaClause) (car cl*)
|
||
|
|
[(clause (,x* ...) ,interface ,body)
|
||
|
|
(min? (cdr cl*)
|
||
|
|
(min (if (fx< interface 0)
|
||
|
|
(fx- -1 interface)
|
||
|
|
interface)
|
||
|
|
m))])))))
|
||
|
|
(define adjust-interface
|
||
|
|
(lambda (x)
|
||
|
|
(if (fx< x 0)
|
||
|
|
(fx+ x m)
|
||
|
|
(fx- x m))))
|
||
|
|
(let ((body (let f ((cl* cl*))
|
||
|
|
(if (null? cl*)
|
||
|
|
($rt lambda (args nargs)
|
||
|
|
($oops #f "incorrect number of arguments to #<procedure>"))
|
||
|
|
(nanopass-case (Linterp CaseLambdaClause) (car cl*)
|
||
|
|
[(clause (,x* ...) ,interface ,body)
|
||
|
|
(ip2-prelude
|
||
|
|
(ip2-body body x* '(a0 a1)
|
||
|
|
(fx< interface 0))
|
||
|
|
(list-tail x* m)
|
||
|
|
(list-tail '(a0 a1) m)
|
||
|
|
(adjust-interface interface)
|
||
|
|
(f (cdr cl*)))])))))
|
||
|
|
(case m
|
||
|
|
[(0)
|
||
|
|
(ip2-closure free
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda args
|
||
|
|
($rt body ([a0 0] [a1 0] [fp 0]) args (length args)))))]
|
||
|
|
[(1)
|
||
|
|
(ip2-closure free
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0 . args)
|
||
|
|
($rt body ([a1 0] [fp 0]) args (length args)))))]
|
||
|
|
[(2)
|
||
|
|
(ip2-closure free
|
||
|
|
($rt lambda ()
|
||
|
|
(lambda (a0 a1 . args)
|
||
|
|
($rt body ([fp 0]) args (length args)))))]))))]
|
||
|
|
[(set! ,x ,e)
|
||
|
|
(let ((e (ip2 e)))
|
||
|
|
(let ((loc (c-var-loc x)) (i (c-var-index x)))
|
||
|
|
(case loc
|
||
|
|
[(a0) ($rt lambda () (set-car! a0 ($rt e)))]
|
||
|
|
[(a1) ($rt lambda () (set-car! a1 ($rt e)))]
|
||
|
|
[(fp) ($rt lambda () (set-car! fp ($rt e)))]
|
||
|
|
[(cp) ($rt lambda () (set-car! cp ($rt e)))]
|
||
|
|
[(frame) ($rt lambda () (set-car! (list-ref fp i) ($rt e)))]
|
||
|
|
[(frame-rest)
|
||
|
|
($rt lambda () (set-car! (list-tail fp i) ($rt e)))]
|
||
|
|
[(closure) ($rt lambda () (set-car! (vector-ref cp i) ($rt e)))]
|
||
|
|
[else (unexpected-loc loc)])))]
|
||
|
|
[(if ,e0 ,e1 ,e2)
|
||
|
|
(let ((e0 (ip2 e0)) (e1 (ip2 e1)) (e2 (ip2 e2)))
|
||
|
|
($rt lambda ()
|
||
|
|
($rt (if ($rt e0) e1 e2))))]
|
||
|
|
[(call ,e ,e* ...)
|
||
|
|
(let ((e* (map (lambda (x) (ip2 x)) e*)))
|
||
|
|
(or (nanopass-case (Linterp Expr) e
|
||
|
|
[,pr
|
||
|
|
(case (length e*)
|
||
|
|
[(0)
|
||
|
|
(let ((e ($top-level-value (primref-name pr))))
|
||
|
|
($rt lambda () (e)))]
|
||
|
|
[(1)
|
||
|
|
(apply
|
||
|
|
(lambda (x1)
|
||
|
|
(let ((e ($top-level-value (primref-name pr))))
|
||
|
|
($rt lambda () (e ($rt x1)))))
|
||
|
|
e*)]
|
||
|
|
[(2)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2)
|
||
|
|
(let ((e ($top-level-value (primref-name pr))))
|
||
|
|
($rt lambda () (e ($rt x1) ($rt x2)))))
|
||
|
|
e*)]
|
||
|
|
[(3)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2 x3)
|
||
|
|
(let ((e ($top-level-value (primref-name pr))))
|
||
|
|
($rt lambda ()
|
||
|
|
(e ($rt x1) ($rt x2) ($rt x3)))))
|
||
|
|
e*)]
|
||
|
|
[else #f])]
|
||
|
|
[(call ,e1 ,e1* ...)
|
||
|
|
(nanopass-case (Linterp Expr) e1
|
||
|
|
[,pr (and (eq? (primref-name pr) '$top-level-value)
|
||
|
|
(fx= (length e*) 1)
|
||
|
|
(nanopass-case (Linterp Expr) (car e1*)
|
||
|
|
[(quote ,d)
|
||
|
|
(and (symbol? d)
|
||
|
|
(case (length e*)
|
||
|
|
[(0) (docall-sym d)]
|
||
|
|
[(1)
|
||
|
|
(apply
|
||
|
|
(lambda (x1)
|
||
|
|
(docall-sym d x1))
|
||
|
|
e*)]
|
||
|
|
[(2)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2)
|
||
|
|
(docall-sym d x1 x2))
|
||
|
|
e*)]
|
||
|
|
[(3)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2 x3)
|
||
|
|
(docall-sym d x1 x2 x3))
|
||
|
|
e*)]
|
||
|
|
[else #f]))]
|
||
|
|
[else #f]))]
|
||
|
|
[else #f])]
|
||
|
|
[else #f])
|
||
|
|
(let ((e (ip2 e)))
|
||
|
|
(case (length e*)
|
||
|
|
[(0) (docallx e)]
|
||
|
|
[(1)
|
||
|
|
(apply
|
||
|
|
(lambda (x1) (docallx e x1))
|
||
|
|
e*)]
|
||
|
|
[(2)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2) (docallx e x1 x2))
|
||
|
|
e*)]
|
||
|
|
[(3)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2 x3) (docallx e x1 x2 x3))
|
||
|
|
e*)]
|
||
|
|
[else (ip2-fat-call e e*)]))))]
|
||
|
|
[(seq ,e1 ,e2)
|
||
|
|
(let ((e1 (ip2 e1)) (e2 (ip2 e2)))
|
||
|
|
($rt lambda () ($rt e1) ($rt e2)))]
|
||
|
|
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
|
||
|
|
(unless $compiler-is-loaded?
|
||
|
|
($oops 'interpret "cannot compile foreign-procedure: compiler is not loaded"))
|
||
|
|
(let ([p ($compile-backend
|
||
|
|
(let ((t (make-prelex* 'tmp)))
|
||
|
|
(set-prelex-referenced! t #t)
|
||
|
|
(with-output-language (Lsrc Expr)
|
||
|
|
`(case-lambda ,(make-preinfo-lambda)
|
||
|
|
(clause (,t) 1
|
||
|
|
(foreign (,conv* ...) ,name (ref #f ,t)
|
||
|
|
(,arg-type* ...) ,result-type))))))])
|
||
|
|
(let ([e (ip2 e)])
|
||
|
|
($rt lambda () ((p) ($rt e)))))]
|
||
|
|
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
|
||
|
|
(unless $compiler-is-loaded?
|
||
|
|
($oops 'interpret "cannot compile foreign-callable: compiler is not loaded"))
|
||
|
|
(let ([p ($compile-backend
|
||
|
|
(let ((t (make-prelex* 'tmp)))
|
||
|
|
(set-prelex-referenced! t #t)
|
||
|
|
(with-output-language (Lsrc Expr)
|
||
|
|
`(case-lambda ,(make-preinfo-lambda)
|
||
|
|
(clause (,t) 1
|
||
|
|
(fcallable (,conv* ...) (ref #f ,t) (,arg-type* ...) ,result-type))))))])
|
||
|
|
(let ([e (ip2 e)])
|
||
|
|
($rt lambda () ((p) ($rt e)))))]
|
||
|
|
[else (unexpected-record x)])))
|
||
|
|
|
||
|
|
(define ip2-prelude
|
||
|
|
(lambda (body vars regs i next)
|
||
|
|
(define set-args
|
||
|
|
(lambda (vars regs body rest?)
|
||
|
|
(if (null? regs)
|
||
|
|
($rt lambda (args) ($rt body ([fp args])))
|
||
|
|
(let ((reg (car regs)))
|
||
|
|
(if (null? (cdr vars))
|
||
|
|
(if rest?
|
||
|
|
(case reg
|
||
|
|
[(a0) ($rt lambda (args) ($rt body ([a0 args])))]
|
||
|
|
[(a1) ($rt lambda (args) ($rt body ([a1 args])))]
|
||
|
|
[(fp) ($rt lambda (args) ($rt body ([fp args])))]
|
||
|
|
[(cp) ($rt lambda (args) ($rt body ([cp args])))]
|
||
|
|
[else (unexpected-loc reg)])
|
||
|
|
(case reg
|
||
|
|
[(a0) ($rt lambda (args) ($rt body ([a0 (car args)])))]
|
||
|
|
[(a1) ($rt lambda (args) ($rt body ([a1 (car args)])))]
|
||
|
|
[(fp) ($rt lambda (args) ($rt body ([fp (car args)])))]
|
||
|
|
[(cp) ($rt lambda (args) ($rt body ([cp (car args)])))]
|
||
|
|
[else (unexpected-loc reg)]))
|
||
|
|
(let ((body (set-args (cdr vars) (cdr regs) body rest?)))
|
||
|
|
(case reg
|
||
|
|
[(a0) ($rt lambda (args)
|
||
|
|
($rt body ([a0 (car args)]) (cdr args)))]
|
||
|
|
[(a1) ($rt lambda (args)
|
||
|
|
($rt body ([a1 (car args)]) (cdr args)))]
|
||
|
|
[(fp) ($rt lambda (args)
|
||
|
|
($rt body ([fp (car args)]) (cdr args)))]
|
||
|
|
[(cp) ($rt lambda (args)
|
||
|
|
($rt body ([cp (car args)]) (cdr args)))]
|
||
|
|
[else (unexpected-loc reg)])))))))
|
||
|
|
(if (fx>= i 0)
|
||
|
|
(if (fx= i 0)
|
||
|
|
($rt lambda (args nargs)
|
||
|
|
(if (fx= nargs 0)
|
||
|
|
($rt body)
|
||
|
|
($rt next () args nargs)))
|
||
|
|
(let ((body (set-args vars regs body #f)))
|
||
|
|
($rt lambda (args nargs)
|
||
|
|
(if (fx= nargs i)
|
||
|
|
($rt body () args)
|
||
|
|
($rt next () args nargs)))))
|
||
|
|
(let ((body (set-args vars regs body #t)))
|
||
|
|
(if (fx= i -1)
|
||
|
|
($rt lambda (args nargs) ($rt body () args))
|
||
|
|
(let ((i (fx- -1 i)))
|
||
|
|
($rt lambda (args nargs)
|
||
|
|
(if (fx>= nargs i)
|
||
|
|
($rt body () args)
|
||
|
|
($rt next () args nargs)))))))))
|
||
|
|
|
||
|
|
(define ip2-closure
|
||
|
|
(lambda (free code)
|
||
|
|
(let ([free (map (lambda (var)
|
||
|
|
(let* ((var (c-var-parent var))
|
||
|
|
(loc (c-var-loc var))
|
||
|
|
(i (c-var-index var)))
|
||
|
|
(case loc
|
||
|
|
[(a0) ($rt lambda () a0)]
|
||
|
|
[(a1) ($rt lambda () a1)]
|
||
|
|
[(fp) ($rt lambda () fp)]
|
||
|
|
[(cp) ($rt lambda () cp)]
|
||
|
|
[(frame) ($rt lambda () (list-ref fp i))]
|
||
|
|
[(frame-rest) ($rt lambda () (list-tail fp i))]
|
||
|
|
[(closure) ($rt lambda () (vector-ref cp i))]
|
||
|
|
[else (unexpected-loc loc)])))
|
||
|
|
free)])
|
||
|
|
(let ((nfree (length free)))
|
||
|
|
(case nfree
|
||
|
|
[(0) ($rt lambda () ($rt code ([cp 0])))]
|
||
|
|
[(1)
|
||
|
|
(apply
|
||
|
|
(lambda (x1)
|
||
|
|
($rt lambda () ($rt code ([cp ($rt x1)]))))
|
||
|
|
free)]
|
||
|
|
[(2)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2)
|
||
|
|
($rt lambda ()
|
||
|
|
($rt code ([cp (vector ($rt x1) ($rt x2))]))))
|
||
|
|
free)]
|
||
|
|
[(3)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2 x3)
|
||
|
|
($rt lambda ()
|
||
|
|
($rt code ([cp (vector ($rt x1) ($rt x2) ($rt x3))]))))
|
||
|
|
free)]
|
||
|
|
[(4)
|
||
|
|
(apply
|
||
|
|
(lambda (x1 x2 x3 x4)
|
||
|
|
($rt lambda ()
|
||
|
|
($rt code ([cp (vector ($rt x1) ($rt x2) ($rt x3) ($rt x4))]))))
|
||
|
|
free)]
|
||
|
|
[else
|
||
|
|
($rt lambda ()
|
||
|
|
(let ((v (make-vector nfree ($rt (car free)))))
|
||
|
|
(do ((i 1 (fx+ i 1)) (free (cdr free) (cdr free)))
|
||
|
|
((null? free))
|
||
|
|
(vector-set! v i ($rt (car free))))
|
||
|
|
($rt code ([cp v]))))])))))
|
||
|
|
|
||
|
|
(define ip2-body
|
||
|
|
(lambda (body invars regs rest?)
|
||
|
|
; set locations
|
||
|
|
(let loop ((vars invars) (regs regs) (i 0))
|
||
|
|
(cond
|
||
|
|
[(null? vars)
|
||
|
|
; process the body and wrap in consers for assigned variables
|
||
|
|
(do ((vars invars (cdr vars))
|
||
|
|
(body (ip2 body)
|
||
|
|
(let ((var (car vars)))
|
||
|
|
(if (prelex-assigned (c-var-id var))
|
||
|
|
(case (c-var-loc var)
|
||
|
|
[(a0)
|
||
|
|
($rt lambda ()
|
||
|
|
($rt body ([a0 (cons a0 (void))])))]
|
||
|
|
[(a1)
|
||
|
|
($rt lambda ()
|
||
|
|
($rt body ([a1 (cons a1 (void))])))]
|
||
|
|
[(fp)
|
||
|
|
($rt lambda ()
|
||
|
|
($rt body ([fp (cons fp (void))])))]
|
||
|
|
[(cp)
|
||
|
|
($rt lambda ()
|
||
|
|
($rt body ([cp (cons cp (void))])))]
|
||
|
|
[(frame)
|
||
|
|
(let ((i (c-var-index var)))
|
||
|
|
($rt lambda ()
|
||
|
|
(let ((ls (list-tail fp i)))
|
||
|
|
(set-car! ls (cons (car ls) (void))))
|
||
|
|
($rt body)))]
|
||
|
|
[(frame-rest)
|
||
|
|
(let ((i (fx- (c-var-index var) 1)))
|
||
|
|
($rt lambda ()
|
||
|
|
(let ((ls (list-tail fp i)))
|
||
|
|
(set-cdr! ls (cons (cdr ls) (void))))
|
||
|
|
($rt body)))])
|
||
|
|
body))))
|
||
|
|
((null? vars) body))]
|
||
|
|
[(not (null? regs))
|
||
|
|
(c-var-loc-set! (car vars) (car regs))
|
||
|
|
(loop (cdr vars) (cdr regs) i)]
|
||
|
|
[(and rest? (null? (cdr vars)))
|
||
|
|
(cond
|
||
|
|
[(fx= i 0)
|
||
|
|
; using fp here instead of the equivalent frame-rest[0]
|
||
|
|
; eliminates need for special-casing frame-rest[0] elsewhere.
|
||
|
|
(c-var-loc-set! (car vars) 'fp)
|
||
|
|
(loop (cdr vars) regs i)]
|
||
|
|
[else
|
||
|
|
(c-var-loc-set! (car vars) 'frame-rest)
|
||
|
|
(c-var-index-set! (car vars) i)
|
||
|
|
(loop (cdr vars) regs (fx+ i 1))])]
|
||
|
|
[else
|
||
|
|
(c-var-loc-set! (car vars) 'frame)
|
||
|
|
(c-var-index-set! (car vars) i)
|
||
|
|
(loop (cdr vars) regs (fx+ i 1))])))))
|
||
|
|
|
||
|
|
(define-pass interpret-Lexpand : Lexpand (ir situation for-import? importer ofn eoo) -> * (val)
|
||
|
|
(definitions
|
||
|
|
(define (ibeval x1)
|
||
|
|
($rt (parameterize ([$target-machine (machine-type)] [$sfd #f])
|
||
|
|
(let* ([x2 ($pass-time 'cpvalid (lambda () ($cpvalid x1)))]
|
||
|
|
[x2a (let ([cpletrec-ran? #f])
|
||
|
|
(let ([x ((run-cp0)
|
||
|
|
(lambda (x)
|
||
|
|
(set! cpletrec-ran? #t)
|
||
|
|
(let ([x ($pass-time 'cp0 (lambda () ($cp0 x #f)))])
|
||
|
|
($pass-time 'cpletrec
|
||
|
|
(lambda () ($cpletrec x)))))
|
||
|
|
x2)])
|
||
|
|
(if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))]
|
||
|
|
[x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]
|
||
|
|
[x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))])
|
||
|
|
(when eoo (pretty-print ($uncprep x2b) eoo))
|
||
|
|
(let ([x ($pass-time 'ip1 (lambda () (ip1 x2b)))])
|
||
|
|
($pass-time 'ip2 (lambda () (ip2 x))))))
|
||
|
|
([a0 0] [a1 0] [fp 0] [cp 0]))))
|
||
|
|
(Inner : Inner (ir) -> * (val)
|
||
|
|
[,lsrc (ibeval lsrc)]
|
||
|
|
[(program ,uid ,body)
|
||
|
|
(ibeval ($build-invoke-program uid body))]
|
||
|
|
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
||
|
|
(ibeval ($build-install-library/ct-code uid export-id* import-code visit-code))]
|
||
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
||
|
|
(ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))]
|
||
|
|
[(library/rt-info ,linfo/rt) ($install-library/rt-desc linfo/rt for-import? importer ofn)]
|
||
|
|
[(library/ct-info ,linfo/ct) ($install-library/ct-desc linfo/ct for-import? importer ofn)]
|
||
|
|
[(program-info ,pinfo) ($install-program-desc pinfo)]
|
||
|
|
[else (sorry! who "unexpected language form ~s" ir)])
|
||
|
|
(Outer : Outer (ir) -> * (val)
|
||
|
|
; can't use cata since (Outer outer1) might return 0 or more than one value
|
||
|
|
[(group ,outer1 ,outer2) (Outer outer1) (Outer outer2)]
|
||
|
|
[(visit-only ,inner) (unless (eq? situation 'revisit) (Inner inner))]
|
||
|
|
[(revisit-only ,inner) (unless (eq? situation 'visit) (Inner inner))]
|
||
|
|
[(recompile-info ,rcinfo) (void)]
|
||
|
|
[,inner (Inner inner)]
|
||
|
|
[else (sorry! who "unexpected language form ~s" ir)])
|
||
|
|
(Outer ir))
|
||
|
|
|
||
|
|
(set! interpret
|
||
|
|
(rec interpret
|
||
|
|
(case-lambda
|
||
|
|
[(x)
|
||
|
|
(interpret x
|
||
|
|
(if (eq? (subset-mode) 'system)
|
||
|
|
($system-environment)
|
||
|
|
(interaction-environment)))]
|
||
|
|
[(x0 env-spec)
|
||
|
|
(unless (environment? env-spec) ($oops 'interpret "~s is not an environment" env-spec))
|
||
|
|
(let ([x1 ($pass-time 'expand
|
||
|
|
(lambda ()
|
||
|
|
(parameterize ([$target-machine (machine-type)] [$sfd #f])
|
||
|
|
(expand x0 env-spec #t))))])
|
||
|
|
($uncprep x1 #t) ; populate preinfo sexpr fields
|
||
|
|
(when (and (expand-output) (not ($noexpand? x0)))
|
||
|
|
(pretty-print ($uncprep x1) (expand-output)))
|
||
|
|
(interpret-Lexpand x1 'load #f #f #f (and (not ($noexpand? x0)) (expand/optimize-output))))])))
|
||
|
|
|
||
|
|
(set! $interpret-backend
|
||
|
|
(lambda (x situation for-import? importer ofn)
|
||
|
|
(interpret-Lexpand x situation for-import? importer ofn (expand/optimize-output))))
|
||
|
|
(current-eval interpret)
|
||
|
|
)
|
||
|
|
|