247 lines
11 KiB
Scheme
247 lines
11 KiB
Scheme
"cprep.ss"
|
|
;;; cprep.ss
|
|
;;; Copyright 1984-2016 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.
|
|
|
|
|
|
(let ()
|
|
(import (nanopass))
|
|
(include "base-lang.ss")
|
|
(include "expand-lang.ss")
|
|
|
|
(define-who Lexpand-to-go
|
|
(lambda (x go)
|
|
(define-pass go-Inner : (Lexpand Inner) (ir) -> * (val)
|
|
(Inner : Inner (ir) -> * (val)
|
|
[,lsrc (go lsrc)]
|
|
[(program ,uid ,body) (go ($build-invoke-program uid body))]
|
|
[(library/ct ,uid ,import-code ,visit-code)
|
|
(go ($build-install-library/ct-code uid import-code visit-code))]
|
|
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
|
(go ($build-install-library/rt-code uid dl* db* dv* de* body))]
|
|
[,linfo/ct `(library/ct-info ,(library-info-uid linfo/ct) ,(library/ct-info-import-req* linfo/ct)
|
|
,(library/ct-info-include-req* linfo/ct) ,(library/ct-info-visit-visit-req* linfo/ct)
|
|
,(library/ct-info-visit-req* linfo/ct))]
|
|
[,linfo/rt `(library/rt-info ,(library-info-uid linfo/rt) ,(library/rt-info-invoke-req* linfo/rt))]
|
|
[,pinfo `(program-info ,(program-info-invoke-req* pinfo))])
|
|
(Inner ir))
|
|
(let ([x* (let f ([x x] [x* '()])
|
|
(nanopass-case (Lexpand Outer) x
|
|
[(group ,outer1 ,outer2) (f outer1 (f outer2 x*))]
|
|
[(visit-only ,inner) (cons `(eval-when (visit) ,(go-Inner inner)) x*)]
|
|
[(revisit-only ,inner) (cons `(eval-when (revisit) ,(go-Inner inner)) x*)]
|
|
[,inner (cons (go-Inner inner) x*)]
|
|
[,rcinfo (cons `(recompile-requirements ,(recompile-info-import-req* x) ,(recompile-info-include-req* x)) x*)]
|
|
[else (sorry! who "unexpected language form ~s" x)]))])
|
|
(safe-assert (not (null? x*)))
|
|
(cond
|
|
[(= (length x*) 1) (car x*)]
|
|
[else `(begin ,@x*)]))))
|
|
|
|
(set-who! $uncprep
|
|
(rec $uncprep
|
|
(case-lambda
|
|
[(x) ($uncprep x #f)]
|
|
[(x sexpr?)
|
|
(define cache-sexpr
|
|
(lambda (preinfo thunk)
|
|
(if sexpr?
|
|
(or (preinfo-sexpr preinfo)
|
|
(let ([sexpr (thunk)])
|
|
(preinfo-sexpr-set! preinfo sexpr)
|
|
sexpr))
|
|
(thunk))))
|
|
(define get-name
|
|
(lambda (x)
|
|
(if sexpr? (prelex-name x) (prelex-uname x))))
|
|
(define uncprep-lambda-clause
|
|
(lambda (cl)
|
|
(nanopass-case (Lsrc CaseLambdaClause) cl
|
|
[(clause (,x* ...) ,interface ,body)
|
|
`(,(if (fx< interface 0)
|
|
(let f ((x* x*))
|
|
(if (pair? (cdr x*))
|
|
(cons (get-name (car x*)) (f (cdr x*)))
|
|
(get-name (car x*))))
|
|
(map get-name x*))
|
|
,@(uncprep-sequence body '()))])))
|
|
(define uncprep-sequence
|
|
(lambda (x ls)
|
|
(nanopass-case (Lsrc Expr) x
|
|
[(profile ,src) (guard (not (null? ls))) ls]
|
|
[(seq ,e1 ,e2)
|
|
(uncprep-sequence e1
|
|
(uncprep-sequence e2 ls))]
|
|
[else (cons (uncprep x) ls)])))
|
|
(define uncprep-fp-conv
|
|
(lambda (x)
|
|
(case x
|
|
[(i3nt-stdcall) '__stdcall]
|
|
[(i3nt-com) '__com]
|
|
[else #f])))
|
|
(define-who uncprep-fp-specifier
|
|
(lambda (x)
|
|
(nanopass-case (Ltype Type) x
|
|
[(fp-void) 'void]
|
|
[(fp-integer ,bits)
|
|
(case bits
|
|
[(8) 'integer-8]
|
|
[(16) 'integer-16]
|
|
[(32) 'integer-32]
|
|
[(64) 'integer-64]
|
|
[else ($oops who "invalid integer size ~s" bits)])]
|
|
[(fp-unsigned ,bits)
|
|
(case bits
|
|
[(8) 'unsigned-8]
|
|
[(16) 'unsigned-16]
|
|
[(32) 'unsigned-32]
|
|
[(64) 'unsigned-64]
|
|
[else ($oops who "invalid unsigned size ~s" bits)])]
|
|
[(fp-scheme-object) 'scheme-object]
|
|
[(fp-u8*) 'u8*]
|
|
[(fp-u16*) 'u16*]
|
|
[(fp-u32*) 'u32*]
|
|
[(fp-fixnum) 'fixnum]
|
|
[(fp-double-float) 'double-float]
|
|
[(fp-single-float) 'single-float]
|
|
[(fp-ftd ,ftd) 'ftype])))
|
|
(define uncprep
|
|
(lambda (x)
|
|
(define keyword?
|
|
(lambda (x)
|
|
(memq x
|
|
; UPDATE THIS if new keywords are added
|
|
'(let $primitive quote begin case-lambda
|
|
library-case-lambda lambda if set!
|
|
letrec letrec* $foreign-procedure
|
|
$foreign-callable eval-when))))
|
|
(nanopass-case (Lsrc Expr) x
|
|
[(ref ,maybe-src ,x) (get-name x)]
|
|
[(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...)
|
|
(guard (fx= (length e*) interface))
|
|
(cache-sexpr preinfo0
|
|
(lambda ()
|
|
(if (null? x*)
|
|
(uncprep body)
|
|
`(let ,(map (lambda (x e)
|
|
`(,(get-name x) ,(uncprep e)))
|
|
x* e*)
|
|
,@(uncprep-sequence body '())))))]
|
|
[(call ,preinfo ,pr (quote ,d))
|
|
(guard (eq? (primref-name pr) '$top-level-value) (symbol? d)
|
|
(not (or (eq? ($real-sym-name d (interaction-environment)) d) (keyword? d))))
|
|
(cache-sexpr preinfo
|
|
(lambda ()
|
|
($real-sym-name d (interaction-environment))))]
|
|
[(call ,preinfo ,pr (quote ,d) ,e)
|
|
(guard (eq? (primref-name pr) '$set-top-level-value!) (symbol? d)
|
|
(not (or (eq? ($real-sym-name d (interaction-environment)) d) (keyword? d))))
|
|
(cache-sexpr preinfo
|
|
(lambda ()
|
|
`(set! ,($real-sym-name d (interaction-environment)) ,(uncprep e))))]
|
|
[(call ,preinfo ,e ,e* ...)
|
|
(cache-sexpr preinfo
|
|
(lambda ()
|
|
`(,(uncprep e) ,@(map uncprep e*))))]
|
|
[,pr (let ([sym (primref-name pr)])
|
|
(if sexpr?
|
|
($sgetprop sym '*unprefixed* sym)
|
|
`($primitive ,(primref-level pr) ,sym)))]
|
|
[(quote ,d)
|
|
(cond
|
|
[(eq? d (void)) '(#2%void)]
|
|
[(self-evaluating? d) d]
|
|
[else `(quote ,d)])]
|
|
[(seq ,e1 ,e2)
|
|
(let ([ls (uncprep-sequence x '())])
|
|
(if (null? (cdr ls))
|
|
(car ls)
|
|
`(begin ,@ls)))]
|
|
[(case-lambda ,preinfo ,cl* ...)
|
|
(cache-sexpr preinfo
|
|
(lambda ()
|
|
(let ((cl* (map uncprep-lambda-clause cl*)))
|
|
(if (and (not (null? cl*)) (null? (cdr cl*)))
|
|
`(lambda ,@(car cl*))
|
|
`(case-lambda ,@cl*)))))]
|
|
[(if ,[e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
|
|
[(set! ,maybe-src ,x ,[e]) `(set! ,(get-name x) ,e)]
|
|
[(letrec ([,x* ,[e*]] ...) ,body)
|
|
`(letrec ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*)
|
|
,@(uncprep-sequence body '()))]
|
|
[(letrec* ([,x* ,[e*]] ...) ,body)
|
|
`(letrec* ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*)
|
|
,@(uncprep-sequence body '()))]
|
|
[(foreign ,conv ,name ,[e] (,arg-type* ...) ,result-type)
|
|
`($foreign-procedure ,(uncprep-fp-conv conv) ,name ,e
|
|
,(map uncprep-fp-specifier arg-type*)
|
|
,(uncprep-fp-specifier result-type))]
|
|
[(fcallable ,conv ,[e] (,arg-type* ...) ,result-type)
|
|
`($foreign-callable ,(uncprep-fp-conv conv) ,e
|
|
,(map uncprep-fp-specifier arg-type*)
|
|
,(uncprep-fp-specifier result-type))]
|
|
[(record-ref ,rtd ,type ,index ,[e]) `(record-ref ,rtd ',type ,e ,index)]
|
|
[(record-set! ,rtd ,type ,index ,[e1] ,[e2]) `(record-set! ,rtd ',type ,e1 ,index ,e2)]
|
|
[(record ,rtd ,[rtd-expr] ,[e*] ...) `(record ,rtd ,rtd-expr ,@e*)]
|
|
[(record-type ,rtd ,[e]) `(record-type ,rtd ,e)]
|
|
[(record-cd ,rcd ,rtd-expr ,[e]) `(record-cd ,rcd ,e)]
|
|
[(immutable-list (,e* ...) ,[e]) e]
|
|
[(moi) ''moi]
|
|
[(pariah) `(pariah (void))]
|
|
[(profile ,src) `(void)]
|
|
[(cte-optimization-loc ,box ,[e]) e]
|
|
; for debugging:
|
|
[(cpvalid-defer ,[e]) `(cpvalid-defer ,e)]
|
|
[else ($oops who "unexpected record ~s" x)])))
|
|
(Lexpand-to-go x uncprep)])))
|
|
|
|
(let ()
|
|
(define (default-env)
|
|
(if (eq? (subset-mode) 'system)
|
|
($system-environment)
|
|
(interaction-environment)))
|
|
(define e/o
|
|
(lambda (who cte? x env)
|
|
(define (go x)
|
|
($uncprep
|
|
($cpcheck
|
|
(let ([cpletrec-ran? #f])
|
|
(let ([x ((run-cp0)
|
|
(lambda (x)
|
|
(set! cpletrec-ran? #t)
|
|
($cpletrec ($cp0 x $compiler-is-loaded?)))
|
|
($cpvalid x))])
|
|
(if cpletrec-ran? x ($cpletrec x)))))))
|
|
(unless (environment? env)
|
|
($oops who "~s is not an environment" env))
|
|
; claim compiling-a-file to get cte as well as run-time code
|
|
(Lexpand-to-go (expand x env #t cte?) go)))
|
|
(set-who! expand/optimize
|
|
(case-lambda
|
|
[(x) (e/o who #f x (default-env))]
|
|
[(x env) (e/o who #f x env)]))
|
|
(set-who! $expand/cte/optimize
|
|
(case-lambda
|
|
[(x) (e/o who #t x (default-env))]
|
|
[(x env) (e/o who #t x env)]))
|
|
(set-who! $expand/cte
|
|
(rec expand/cte
|
|
(case-lambda
|
|
[(x) (expand/cte x (default-env))]
|
|
[(x env)
|
|
(unless (environment? env)
|
|
($oops who "~s is not an environment" env))
|
|
; claim compiling-a-file to get cte as well as run-time code
|
|
($uncprep (expand x env #t #t))])))))
|