This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/interpret.ss
2022-07-29 15:12:07 +02:00

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)
)