suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adding kim's optimizer

Browse Source 
svn: r5342
This commit is contained in:
Greg Cooper 2007-01-12 23:47:08 +00:00
parent ba1305ba3b
commit 441a48c33b
7 changed files with 1150 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/frtime/date.ss
View File

@ -1,8 +1,8 @@
(module date mzscheme (module date mzscheme
(require (lib "list.ss") (require "list.ss")
(rename "frtime.ss" frtime:provide provide)) (require (rename "frtime.ss" frtime:provide provide))
(frtime:provide (frtime:provide
(lifted date->string (lifted date->string
@ -117,14 +117,14 @@
[(chinese) [(chinese)
(values (values
(list year "/" num-month "/" day (list year "/" num-month "/" day
" libai" (case (date-week-day date) " \u661F\u671F" (case (date-week-day date)
[(0) "tian"] [(0) "\u5929"]
[(1) "yi"] [(1) "\u4E00"]
[(2) "er"] [(2) "\u4E8C"]
[(3) "san"] [(3) "\u4e09"]
[(4) "si"] [(4) "\u56DB"]
[(5) "wu"] [(5) "\u4E94"]
[(6) "liu"] [(6) "\u516D"]
[else ""])) [else ""]))
(list " " hour24 ":" minute ":" second))] (list " " hour24 ":" minute ":" second))]
[(indian) [(indian)

19
collects/frtime/frp-core.ss
View File

@ -24,11 +24,11 @@
(define frtime-version "0.3b -- Tue Nov 9 13:39:45 2004") (define frtime-version "0.3b -- Tue Nov 9 13:39:45 2004")
(define (compose-continuation-mark-sets2 s1 s2) (define (compose-continuation-mark-sets2 s1 s2)
s2) (append s1 s2))
(define (my-ccm)
(continuation-mark-set->list (current-continuation-marks) 'drscheme-debug-continuation-mark-key))
;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;
;; Structures ;; ;; Structures ;;
@ -65,7 +65,7 @@
(lambda (fn . args) (lambda (fn . args)
(unregister #f fn) ; clear out stale dependencies from previous apps (unregister #f fn) ; clear out stale dependencies from previous apps
(let* (; revisit error-reporting for switched behaviors (let* (; revisit error-reporting for switched behaviors
[ccm (current-continuation-marks)] [ccm (my-ccm)]
[app-fun (lambda (cur-fn) [app-fun (lambda (cur-fn)
(let ([res (apply cur-fn args)]) (let ([res (apply cur-fn args)])
(when (signal? res) (when (signal? res)
@ -152,8 +152,8 @@
"extra marks present!" (extra-cont-marks))))) "extra marks present!" (extra-cont-marks)))))
(compose-continuation-mark-sets2 (compose-continuation-mark-sets2
(extra-cont-marks) (extra-cont-marks)
(current-continuation-marks))) (my-ccm)))
(current-continuation-marks))) (my-ccm)))
;; Simple Structure Combinators ;; Simple Structure Combinators
@ -678,7 +678,12 @@
(let ([new-value (call-with-parameterization (let ([new-value (call-with-parameterization
params params
thunk)]) thunk)])
(if (or (signal:unchanged? b) (not (eq? value new-value))) (if (or (signal:unchanged? b)
(not (or (boolean? new-value)
(symbol? new-value)
(number? new-value)
(string? new-value)))
(not (eq? value new-value)))
(begin (begin
#;(if (signal? new-value) #;(if (signal? new-value)
(raise (make-exn:fail (raise (make-exn:fail

204
collects/frtime/frtime-opt-lang.ss Normal file
View File

@ -0,0 +1,204 @@
;; This module defines all the functions necessary to write FrTime programs,
;; as well as their lowered equivalents. It doesn't know how to perform
;; optimization, though -- that is left to the frtime-opt module.
(module frtime-opt-lang mzscheme
(require (prefix frtime: (lib "frtime.ss" "frtime")))
(require-for-syntax (lib "lowered-equivs.ss" "frtime"))
;; Export a function that is just a lifted version of a standard
;; function (with the same name).
;; TBD: don't import from frtime at all -- just lift the original function
(define-syntax (provide/lifted stx)
(syntax-case stx ()
[(_ MOD FUNC)
(let ([lowered-equiv-id (make-lowered-equiv-id #'FUNC)])
#`(begin (require (rename (lib "frtime-big.ss" "frtime") lifted-func FUNC))
(provide (rename lifted-func FUNC))
(require (rename MOD #,lowered-equiv-id FUNC))
(provide #,lowered-equiv-id)))]
[(_ MOD FUNC FUNCS ...)
#`(begin (provide/lifted MOD FUNC)
(provide/lifted MOD FUNCS ...))]))
(define-syntax (provide/already-lowered stx)
(syntax-case stx ()
[(_ FUNC)
(let ([lowered-equiv-id (make-lowered-equiv-id #'FUNC)])
#`(begin (require (only (lib "frtime-big.ss" "frtime") FUNC))
;; note: the definition is necessary here because otherwise the lowered
;; equiv doesn't become part of the module's namespace, and there's
;; no way to find the list of identifiers exported by a module other
;; than by filtering its namespace (see all-provided-symbols in
;; lowered-equivs.ss)
(define #,lowered-equiv-id FUNC)
(provide FUNC)
(provide #,lowered-equiv-id)))]
[(_ FUNC FUNCS ...)
#`(begin (provide/already-lowered FUNC)
(provide/already-lowered FUNCS ...))]))
(define-syntax provide/no-equiv
(syntax-rules ()
[(_ FUNC)
(begin (require (rename (lib "frtime-big.ss" "frtime") func FUNC))
(provide (rename func FUNC)))]
[(_ FUNC FUNCS ...)
(begin (provide/no-equiv FUNC)
(provide/no-equiv FUNCS ...))]))
(provide/lifted mzscheme
;; equality
eq? equal? eqv?
;; types
boolean? symbol? #;vector? number? string? char? pair? void? procedure? #;port? eof-object?
;; numbers and math
zero? even? odd? positive? negative? integer? real? rational? complex? exact? inexact?
+ - * / quotient remainder modulo
= < > <= >=
add1 sub1 min max
cos sin tan atan asin acos ;; trig
abs log sqrt integer-sqrt exp expt floor ceiling round truncate ;; reals
numerator denominator rationalize lcm gcd ;; fractions
imag-part real-part magnitude angle make-rectangular make-polar ;; complex numbers
bitwise-not bitwise-xor bitwise-and bitwise-ior arithmetic-shift ;; bits
;; booleans and conditionals
and or not when unless cond case
;; characters
char>? char<? char=? char-ci>=? char-ci<=? char>=? char<=?
char-upper-case? #;char-lower-case? char-alphabetic? char-numeric? char-whitespace?
char-upcase char-downcase
;; strings
string string-length string-append substring string-ref
string=? string<? string<=? string>? string>=?
string-ci=? string-ci<? string-ci<=? #;string-ci>? string-ci>=?
string-locale-ci=? string-locale<? string-locale-ci<? string-locale-ci>?
format
;; lists
null? list? car cdr caar cadr cddr caddr cdddr cadddr cddddr
length list-ref list-tail
assq assv #;assoc memq memv #;member
;; vectors
make-vector vector #;vector-length vector-ref
;; dates
make-date date? date-dst? seconds->date current-seconds current-milliseconds
date-year date-month date-day date-year-day date-week-day
date-hour date-minute date-second date-time-zone-offset
;; conversion
char->integer integer->char
symbol->string string->symbol
number->string string->number
list->string string->list
list->vector vector->list
inexact->exact exact->inexact
;; exceptions
exn-message exn-continuation-marks exn:fail? continuation-mark-set->list
with-handlers
;; syntax
expand #;expand-syntax syntax syntax-object->datum syntax-case syntax-rules
;; paths
path? path-string? string->path path->string
bytes->path path->bytes build-path absolute-path? relative-path?
complete-path? path->complete-path resolve-path path-replace-suffix
expand-path simplify-path normal-case-path split-path
;; I/O
printf fprintf file-exists? #;link-exists? #;make-file-or-directory-link
#;file-or-directory-modify-seconds #;file-or-directory-permissions
#;rename-file-or-directory #;file-size #;copy-file #;delete-file
;; context
current-error-port current-security-guard collection-path
#;current-namespace #;current-command-line-arguments #;current-custodian
current-directory #;current-eventspace
;; misc
eval procedure-arity regexp-match void system-type
)
(provide/lifted (lib "1.ss" "srfi")
first second)
;; things that serve as their own lowered equivalent
(provide/already-lowered
event-receiver send-event
nothing null collect-garbage)
;; functions with no lowered equivalents
(provide/no-equiv
;; no equiv because these inherently work with signals
seconds milliseconds value-now value-now/sync value-now/no-copy inf-delay delay-by synchronize
for-each-e! map-e filter-e merge-e once-e accum-e accum-b collect-e collect-b when-e while-e -=> ==> =#>
changes hold switch snapshot snapshot/sync snapshot-e integral derivative
signal? undefined? undefined lift-strict =#=>
;; no equiv because we don't support lvalues
set! set-cell! new-cell
;; no equiv because we have special handling for these special forms
begin if let let* let-values letrec #;letrec-values
define-values values define-syntax define-syntaxes
;; no lowered equiv because it allocates memory
list list* cons reverse append
;; no equiv because it's a macro that expands into more primitive code
case-lambda let*-values mk-command-lambda
;; no equiv because these accept higher-order functions, which may not
;; have been lowered
for-each map andmap ormap apply ;build-string #;build-vector
;; no equiv because these have non-local control flow (can't get your
;; hands on the return value in order to lift it again).
raise raise-exceptions raise-type-error error exit let/ec
;; no equiv because I haven't completely thought through these
lambda quote quasiquote unquote unquote-splicing make-parameter parameterize
procedure-arity-includes? dynamic-require)
(provide #%app #%top #%datum require require-for-syntax provide define)
(provide display) ;; for debugging
;; this define-struct macro defines a lowered equiv for all the
;; accessor functions
(define-syntax (my-define-struct stx)
(define (make-lowered-accessor struct-id field-id)
(let* ([upper-id (datum->syntax-object
field-id
(string->symbol
(format "~s-~s"
(syntax-e struct-id)
(syntax-e field-id))))]
[lower-id (make-lowered-equiv-id upper-id)])
;; TBD: can we be smarter? can we go straight for the field value and
;; bypass any signal-checking logic? *is* there any signal-checking logic?
#`(define #,lower-id #,upper-id)))
(define (lowered-equiv-defns struct-id field-ids)
(let ([lowered-accessors (map (lambda (field-id)
(make-lowered-accessor struct-id field-id))
field-ids)])
#`(begin . #,lowered-accessors)))
(syntax-case stx ()
[(_ (STRUCT BASE) (FIELD ...) . REST)
#`(begin
(frtime:define-struct (STRUCT BASE) (FIELD ...) . REST)
#,(lowered-equiv-defns #'STRUCT (syntax->list #'(FIELD ...))))]
[(_ STRUCT (FIELD ...) . REST)
#`(begin
(frtime:define-struct STRUCT (FIELD ...) . REST)
#,(lowered-equiv-defns #'STRUCT (syntax->list #'(FIELD ...))))]))
(provide (rename my-define-struct define-struct))
)

779
collects/frtime/frtime-opt.ss Executable file
View File

@ -0,0 +1,779 @@
;; This module serves as a language module for an optimized version of FrTime.
;; The only thing it exports is a #%module-begin macro that knows how to
;; perform optimization of FrTime functions. The rest of the language
;; (i.e. all the functions needed to actually write FrTime programs) is
;; provided by the frtime-opt-lang module, which is automatically imported.
(module frtime-opt mzscheme
(provide (rename my-module-begin #%module-begin)
#%app #%top #%datum optimize-expr optimize-module dont-optimize)
(require-for-syntax (lib "lowered-equivs.ss" "frtime"))
(require-for-syntax (only (lib "1.ss" "srfi") lset-union lset-difference every))
(require-for-syntax (lib "list.ss"))
(require (only (lib "frp-core.ss" "frtime") super-lift undefined undefined?))
(require (rename (lib "lang-ext.ss" "frtime") frtime:lift lift)
(rename (lib "mzscheme-core.ss" "frtime") frtime:if if)
(only (lib "mzscheme-core.ss" "frtime") frp:copy-list))
; (require (lib "unit.ss") (lib "unitsig.ss"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helper functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; prevent a subexpression from being optimized. Calls to this function
;; are specifically recognized, and handled specially.
(define (dont-optimize x) x)
;; like module-identifier=?, but returns #f for non-identifier arguments
;; instead of throwing an exception
(define-for-syntax (safe-module-identifier=? id1 id2)
(and (identifier? id1)
(identifier? id2)
(module-identifier=? id1 id2)))
;; Convert a syntax-object to a datum and back again. This replaces all
;; the context information. It's necessary to get generated require
;; statements to work, for some reason.
;; See http://list.cs.brown.edu/pipermail/plt-scheme/2006-July/014163.html
(define-for-syntax (so->d->so ref-stx stx)
(datum->syntax-object ref-stx (syntax-object->datum stx)))
;; Convert a syntactic module reference to a module-path-index
(define-for-syntax (module-stx-to-path-index mod-stx)
(let ([mod (syntax-object->datum mod-stx)])
(if (symbol? mod)
mod
(module-path-index-join mod #f))))
;; Convert a syntactic module reference to a module-path (this is
;; subtly different from a module-path-index)
(define-for-syntax (module-stx-to-path mod-stx)
(syntax-object->datum mod-stx))
;; Does the given module export the given id?
(define-for-syntax (module-exports-id? mod-stx id-stx)
(not (module-provide-protected? (module-stx-to-path-index mod-stx)
(syntax-e id-stx))))
;; Returns all the identifiers exported by a module
(define-for-syntax (all-provided-ids mod-stx ref-stx)
;; we get exn:fail:filesystem if the module doesn't exist.
;; we get exn:fail:contract during compilation if compiling a module that
;; imports mred.
(with-handlers ([exn:fail:filesystem? (lambda (exn) null)]
[exn:fail:contract? (lambda (exn) null)])
(let ([mod-path (module-stx-to-path mod-stx)]
[mod-path-index (module-stx-to-path-index mod-stx)])
;; instantiate the module so we can call module->namespace on it
(dynamic-require mod-path #f)
;; get the list of provided symbols
(let* ([all-symbols (namespace-mapped-symbols (module->namespace mod-path))]
[exported-symbols (filter
(lambda (id) (not (module-provide-protected? mod-path-index id)))
all-symbols)]
[exported-ids (map
(lambda (symbol) (datum->syntax-object ref-stx symbol))
exported-symbols)])
exported-ids))))
;; This macro takes a list of variables and an expression.
;; The variables are projected before evaluating the expression,
;; and the result is then injected into the dataflow graph as a
;; single node.
(require (only (lib "frp-core.ss" "frtime") proc->signal value-now))
(define-syntax (dip stx)
(syntax-case stx (begin)
;; special case: don't dip lone identifiers
[(_ (VAR ...) VAR2)
(identifier? #'VAR2)
#'VAR2]
;; special case: strip off unnecessary begins
[(_ (VAR ...) (begin E))
#'(dip (VAR ...) E)]
;; special case: don't bother dipping if there are no dependencies
[(_ () EXPR)
#'EXPR]
;; general case: wrap the subexpression in a lambda, and lift it
[(_ (VAR ...) EXPR)
#'(frtime:lift
#t
(lambda (VAR ...) EXPR)
VAR ...)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Module-level optimization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Wrap the entire module body in an optimize-module macro.
(define-syntax (my-module-begin stx)
(syntax-case stx ()
[(_ FORMS ...)
(let* (;; get a list of all the symbols provided by the frtime-opt-lang module
[lang-symbols (all-provided-ids #'(lib "frtime-opt-lang.ss" "frtime") stx)]
;; convert those symbols into an equiv-map by pairing up functions
;; with their lowered equivalents
[lang-equiv-map (symbol-list-to-equiv-map lang-symbols)]
;; convert the equiv-map to syntax so we can embed it in the call
;; to optimize-module
[equiv-map-stx (equiv-map-to-stx lang-equiv-map)])
#`(#%plain-module-begin
(require-for-syntax #,(so->d->so stx #`mzscheme))
(require #,(so->d->so stx #`(lib "frtime-opt-lang.ss" "frtime")))
(optimize-module #,equiv-map-stx FORMS ...)))]))
;; Expand a module body until it's just top-level definitions, and then
;; separately optimize each kind of top-level definition.
(define-syntax (optimize-module stx)
(syntax-case stx ()
[(_ EQUIV-MAP)
#`(begin)]
[(_ EQUIV-MAP FORM FORMS ...)
(let ([expanded-form
(local-expand #'FORM 'module
(list #'begin #'begin0 #'provide #'require #'require-for-syntax
#'define-syntaxes #'define-values-for-syntax
#'define-values #'#%app #'unit #'unit/sig))])
(syntax-case expanded-form (begin begin0 provide require require-for-syntax
define-syntaxes define-values-for-syntax
define-values #%app)
;; explode top-level begin statements
[(begin MORE-FORMS ...)
#`(optimize-module EQUIV-MAP MORE-FORMS ... FORMS ...)]
;; require
[(require . __)
#`(optimize-require EQUIV-MAP #,expanded-form FORMS ...)]
;; require-for-syntax
[(require-for-syntax . __)
#`(begin #,expanded-form
(optimize-module EQUIV-MAP FORMS ...))]
;; provide
[(provide . __)
;; TBD: provide lowered equivs as well.
;; TBD: support frtime-specific provide specs (lifted, etc)
#`(begin #,expanded-form
(optimize-module EQUIV-MAP FORMS ...))]
;; syntax definitions
[(define-syntaxes . __)
#`(begin #,expanded-form
(optimize-module EQUIV-MAP FORMS ...))]
[(define-values-for-syntax . __)
#`(begin #,expanded-form
(optimize-module EQUIV-MAP FORMS ...))]
;; top-level variable definitions
[(define-values (ID ...) VAL)
#`(begin
(optimize-definition EQUIV-MAP #,expanded-form FORMS ...))]
;; expressions
[else
#`(begin
(optimize-expr EQUIV-MAP #,expanded-form)
(optimize-module EQUIV-MAP FORMS ...))]))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Require/Provide handling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rewrite require forms so that they import not only regular identifiers,
;; but also lowered equivalents, and add those lowered equivs to the equiv map.
(define-syntax (optimize-require stx)
;; Take a module and a list of identifiers, and return the list of
;; associated lowered equivalents (for those identifiers that have one).
(define (module-lowered-equivs mod-stx id-stx-list)
(map make-lowered-equiv-id
(filter (lambda (id-stx)
(module-exports-id? mod-stx (make-lowered-equiv-id id-stx)))
id-stx-list)))
(syntax-case stx (require)
[(_ EQUIV-MAP (require SPEC) FORMS ...)
;; In the code below, we must convert syntax objects to datums, and then
;; back again. Otherwise the generated require statement doesn't
;; seem to work properly (it doesn't import the correct identifiers).
;; See http://list.cs.brown.edu/pipermail/plt-scheme/2006-July/014163.html
(syntax-case #'SPEC (only prefix all-except prefix-all-except rename
lifted lifted:nonstrict as-is as-is:unchecked)
[(only MOD ID ...)
;; Add lowered equivs to the list of ids to import
(let ([lowered-equivs
(module-lowered-equivs #'MOD (syntax->list #'(ID ...)))]
[new-equiv-map #'EQUIV-MAP])
#`(begin
(require #,(so->d->so #'MOD #`(only MOD ID ... . #,lowered-equivs)))
(optimize-module #,new-equiv-map FORMS ...)))]
[(prefix PFX MOD)
;; Requiring the entire module with a prefix will automatically import
;; the lowered-equiv bindings with the same prefix.
(let ([new-equiv-map #'EQUIV-MAP])
#`(begin
(require #,(so->d->so #'MOD #`(prefix PFX MOD)))
(optimize-module #,new-equiv-map FORMS ...)))]
[(all-except MOD ID ...)
;; Add the lowered-equiv ids to the exclude list. If they aren't actually
;; provided by the module then they will be silently ignored.
(let ([lowered-equivs
(module-lowered-equivs #'MOD (syntax->list #'(ID ...)))]
[new-equiv-map #'EQUIV-MAP])
#`(begin
(require #,(so->d->so #'MOD #`(all-except MOD ID ... . #,lowered-equivs)))
(optimize-module #,new-equiv-map FORMS ...)))]
[(prefix-all-except PFX MOD ID ...)
;; Add the lowered-equiv bindings to the exclude list.
(let ([lowered-equivs
(module-lowered-equivs #'MOD (syntax->list #'(ID ...)))]
[new-equiv-map #'EQUIV-MAP])
#`(begin
(require #,(so->d->so #'MOD #`(prefix-all-except PFX MOD ID ... . #,lowered-equivs)))
(optimize-module #,new-equiv-map FORMS ...)))]
[(rename MOD LOCAL-ID EXPORTED-ID)
;; Rename the lowered-equiv binding as well.
(let* ([exported-lowered-equiv-id (make-lowered-equiv-id #'EXPORTED-ID)]
[local-lowered-equiv-id (make-lowered-equiv-id #'LOCAL-ID)]
[has-lowered-equiv (module-exports-id? #'MOD
exported-lowered-equiv-id)])
(if has-lowered-equiv
#`(begin
(require #,(so->d->so #'MOD #`(rename MOD LOCAL-ID EXPORTED-ID)))
(require #,(so->d->so #'MOD #`(rename MOD
#,local-lowered-equiv-id
#,exported-lowered-equiv-id)))
(optimize-module ((LOCAL-ID #,local-lowered-equiv-id) . EQUIV-MAP) FORMS ...))
#`(begin
(require #,(so->d->so #'MOD #`(rename MOD LOCAL-ID EXPORTED-ID)))
(optimize-module EQUIV-MAP FORMS ...))))]
[(LIFTED MOD ID)
;; import the identifier itself as the lowered equiv, and define a new, lifted, version.
(and (identifier? #'LIFTED)
(or (free-identifier=? #'LIFTED #'lifted)
(free-identifier=? #'LIFTED #'lifted:nonstrict)))
(let* ([lowered-equiv-id (make-lowered-equiv-id #'ID)]
[strict? (datum->syntax-object #'MOD (free-identifier=? #'LIFTED #'lifted))])
#`(begin
(require #,(so->d->so #'MOD #`(rename MOD #,lowered-equiv-id ID)))
(define (ID . args) (apply frtime:lift #,strict? #,lowered-equiv-id args))
(optimize-require ((ID #,lowered-equiv-id) . EQUIV-MAP) FORMS ...)))]
[(LIFTED MOD ID IDS ...)
;; only import one lifted identifier at a time
(and (identifier? #'LIFTED)
(or (free-identifier=? #'LIFTED #'lifted)
(free-identifier=? #'LIFTED #'lifted:nonstrict)))
#`(optimize-require EQUIV-MAP
(require (LIFTED MOD ID))
(require (LIFTED MOD IDS ...))
FORMS ...)]
[(AS-IS MOD IDS ...)
;; as-is and as-is:unchecked are treated just like (require (only ...))
(and (identifier? #'AS-IS)
(or (free-identifier=? #'AS-IS #'as-is)
(free-identifier=? #'AS-IS #'as-is:unchecked)))
#`(optimize-require EQUIV-MAP
(require #,(so->d->so #'MOD #`(only MOD IDS ...)))
FORMS ...)]
[MOD
;; Requiring an entire module will automatically import the lowered-equiv
;; bindings, so we don't need to change the require directive itself, just
;; the equiv map.
;; Vote: it's very important to use #'SPEC as the ref-stx here. If you
;; use #'MOD or stx instead, then the identifiers returned by all-provided-ids
;; will not be module-identifier=? to the identifiers in the actual code.
;; TBD: make the initial import of frtime-opt-lang use this same mechanism.
(let* ([additional-equiv-map (symbol-list-to-equiv-map
(all-provided-ids #'MOD #'SPEC))]
[new-equiv-map-stx (equiv-map-to-stx
(union-equiv-maps additional-equiv-map
(stx-to-equiv-map #'EQUIV-MAP)))])
#`(begin (require MOD)
(optimize-module #,new-equiv-map-stx FORMS ...)))]
)]
[(_ EQUIV-MAP (require SPECS ...) FORMS ...)
;; Process each require spec individually.
#`(optimize-require EQUIV-MAP (require SPECS) ... FORMS ...)]
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Expression optimization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helper functions for working with dipped expressions
(define-for-syntax (dipped? stx)
(syntax-case stx (dip)
[(dip . _) #t]
[ELSE #f]))
(define-for-syntax (get-dipped-expr stx)
(syntax-case stx (dip)
[(dip DEPS EXPR)
#'EXPR]))
(define-for-syntax (get-dipped-deps stx)
(syntax-case stx (dip)
[(dip (DEP ...) EXPR)
(syntax->list #'(DEP ...))]))
(define-for-syntax (union-id-lists . id-lists)
(foldl (lambda (l1 l2)
(lset-union bound-identifier=? l1 l2))
()
id-lists))
(define-for-syntax (diff-id-lists id-list1 id-list2)
(lset-difference bound-identifier=? id-list1 id-list2))
;; return the list of identifiers in an argument list.
;; #'(a b c) => (list #'a #'b #'c)
;; #'(x y . rest) => (list #'x #'y #'rest)
;; #'args => (list #'args)
(define-for-syntax (extract-args stx)
(syntax-case stx ()
[ID
(identifier? #'ID)
(list #'ID)]
[(ID . REST)
(append (extract-args #'ID)
(extract-args #'REST))]
[()
()]
[ELSE
(raise-syntax-error #f "doesn't look like an arg list" stx)]))
;; return the rest arg from an argument list.
;; #'(a b . rest) => #'rest
;; #'args => #'args
(define-for-syntax (extract-rest-arg stx)
(syntax-case stx ()
[ID
(identifier? #'ID)
#'ID]
[(ID . REST)
(identifier? #'REST)
#'REST]
[(ID . REST)
(extract-rest-arg #'REST)]
[ELSE
(raise-syntax-error #f "cannot extract rest arg" stx)]))
;; search and replace an identifier in a syntax object
(define-for-syntax (replace-id stx old-id new-id)
(syntax-case stx ()
[ID
(and (identifier? #'ID)
(module-identifier=? old-id #'ID))
new-id]
[(X . Y)
(datum->syntax-object
stx
(cons (replace-id #'X old-id new-id)
(replace-id #'Y old-id new-id)))]
[()
()]
[ELSE
stx]))
;; return #t if a syntax object refers to a given id
(define-for-syntax (refers-to-id? stx id)
(syntax-case stx ()
[ID
(and (identifier? #'ID)
(module-identifier=? id #'ID))
#t]
[(X . Y)
(or (refers-to-id? #'X id)
(refers-to-id? #'Y id))]
[ELSE #f]))
;; Optimize an expression by dipping subexpressions wherever possible.
;;
;; Note: this function does not intercept syntax errors due to misused
;; certificates. It's up to the caller to handle that.
(define-for-syntax (recursively-optimize-expr stx equiv-map lower-lambda)
(syntax-case stx (#%datum #%top #%app quote begin begin0 lambda case-lambda
let-values letrec-values letrec-syntaxes+values
unit unit/sig if super-lift undefined? undefined rename
frp:copy-list frp:->boolean dont-optimize)
[(#%datum . _)
#`(dip () #,stx)]
[(#%top . X)
#`(dip (X) X)]
[X
(identifier? #'X)
#`(dip (X) X)]
[(quote EXPR)
#`(dip () #,stx)]
[(BEGIN EXPR ...)
(and (identifier? #'BEGIN)
(or (module-identifier=? #'BEGIN #'begin)
(module-identifier=? #'BEGIN #'begin0)))
(let* ([optimized-exprs (map (lambda (expr)
(recursively-optimize-expr expr equiv-map #f))
(syntax->list #'(EXPR ...)))]
[all-exprs-were-dipped (every dipped? optimized-exprs)])
(if all-exprs-were-dipped
(let ([deps (apply union-id-lists (map get-dipped-deps optimized-exprs))]
[lowered-exprs (map get-dipped-expr optimized-exprs)])
#`(dip #,deps (begin . #,lowered-exprs)))
;; we can't dip the entire subexpression, but we may have been able
;; to optimize some of the exprs.
#`(begin . #,optimized-exprs)))]
[(lambda ARGS (let-values (((REST) (#%app frp:copy-list REST_))) EXPRS ...))
;; If frtime sees a lambda with a rest arg, it inserts a call to
;; frp:copy-list. Recognize this pattern and ignore it if we're lowering
;; instead of dipping.
(let* ([rest-arg (extract-rest-arg #`ARGS)]
;; have to replace REST to avoid "identifier used out of context" errors
[body (replace-id #`(begin EXPRS ...) #'REST rest-arg)]
[optimized-body (recursively-optimize-expr body equiv-map #f)])
(if (and lower-lambda (dipped? optimized-body))
(let* ([lowered-body (get-dipped-expr optimized-body)]
[body-deps (get-dipped-deps optimized-body)]
[new-deps (diff-id-lists body-deps (extract-args #`ARGS))])
#`(dip #,new-deps (lambda ARGS #,lowered-body)))
(if (refers-to-id? optimized-body rest-arg)
#`(lambda ARGS
(let-values (((#,rest-arg) (frp:copy-list #,rest-arg)))
#,optimized-body))
#`(lambda ARGS #,optimized-body))))]
[(lambda ARGS EXPRS ...)
;; If "lower-lambda" is true, then we know that it's safe to lower the
;; body of the lambda. "lower-lambda" should only be true if we know
;; that the result will be immediately bound to a variable that is
;; guaranteed never to be called except in a lowered context. In contrast,
;; if we always lowered the body of a lambda, the closure might escape
;; to where it could be called with time-varying arguments.
(let* ([body #`(begin EXPRS ...)]
[optimized-body (recursively-optimize-expr body equiv-map #f)])
(if (and lower-lambda (dipped? optimized-body))
(let* ([lowered-body (get-dipped-expr optimized-body)]
[body-deps (get-dipped-deps optimized-body)]
[new-deps (diff-id-lists body-deps (extract-args #'ARGS))])
#`(dip #,new-deps (lambda ARGS #,lowered-body)))
#`(lambda ARGS #,optimized-body)))]
[(case-lambda (FORMALS EXPR ...) ...)
;; dip each clause separately. TODO: pay attention to lower-lambda
(let* ([bodies (syntax->list #`((begin EXPR ...) ...))]
[optimized-bodies (map (lambda (expr)
(recursively-optimize-expr expr equiv-map #f))
bodies)]
[args (syntax->list #`(FORMALS ...))]
[clauses (map list args optimized-bodies)])
#`(case-lambda . #,clauses))]
;; special case: recognize the expanded version of "let loop" and allow
;; it to be fully lowered. Otherwise it ends up calling itself, and since
;; we don't define a fully lowered equivalent of the loop itself, then
;; whole thing ends up using signal:switching, which is slow.
;; TBD: "let loop" embeds its letrec-values in an #%app -- we could
;; recognize this and avoid defining the upper version at all.
[(#%app (letrec-values (((LOOP) BODY))
LOOP_) ARG ...)
(and (identifier? #'LOOP)
(identifier? #'LOOP_)
(module-identifier=? #'LOOP #'LOOP_))
(let* ([optimized-args (map (lambda (e)
(recursively-optimize-expr e equiv-map #f))
(syntax->list #'(ARG ...)))]
[loop-lowered-id (make-lowered-equiv-id #'LOOP)]
[extended-equiv-map (add-equiv-map equiv-map #'LOOP loop-lowered-id)]
;; allow lambdas to be lowered, because "let loop" generates a lambda
[lowered-body (recursively-optimize-expr #'BODY extended-equiv-map #t)])
;; if the body can be fully lowered, and the lower version doesn't refer to
;; the upper version, then we can define both an upper and a lower definition,
;; and return the upper one.
(if (dipped? lowered-body)
(if (every dipped? optimized-args)
;; all the args were dippable -- we can lower the *entire* thing, and
;; do away with the upper version of the loop.
(let* ([lowered-expr (get-dipped-expr lowered-body)]
[lowered-deps (get-dipped-deps lowered-body)]
[deps (apply union-id-lists lowered-deps
(map get-dipped-deps optimized-args))])
#`(dip #,deps
(#%app (letrec-values (((#,loop-lowered-id) #,lowered-expr))
#,loop-lowered-id)
#,@(map get-dipped-expr optimized-args))))
;; at least one arg wasn't dippable, so we have to keep the upper version,
;; and we can't dip the entire expression.
(let* ([optimized-body (recursively-optimize-expr #'BODY extended-equiv-map #f)]
[lowered-expr (get-dipped-expr lowered-body)]
[lowered-deps (get-dipped-deps lowered-body)]
[deps (diff-id-lists lowered-deps (list #'LOOP))])
#`(#%app (dip #,deps
(letrec-values (((#,loop-lowered-id) #,lowered-expr)
((LOOP) #,optimized-body))
LOOP))
#,@optimized-args)))
(let* ([optimized-body (recursively-optimize-expr #'BODY equiv-map #f)])
#`(#%app (letrec-values (((LOOP) #,optimized-body))
LOOP)
#,@optimized-args))))]
[(LET-VALUES ((VARS VALS) ...) EXPR ...)
(and (identifier? #'LET-VALUES)
(or (module-identifier=? #'LET-VALUES #'let-values)
(module-identifier=? #'LET-VALUES #'letrec-values)))
(let* ([bindings (syntax->list #'(VARS ...))]
[flattened-bindings (apply append (map syntax->list bindings))]
[body #`(begin EXPR ...)]
[optimized-body (recursively-optimize-expr body equiv-map lower-lambda)]
;; TBD: consider defining lowered equivs for local bindings
[optimized-vals (map (lambda (arg)
(recursively-optimize-expr arg equiv-map #f))
(syntax->list #'(VALS ...)))]
[all-exprs-were-dipped (and (dipped? optimized-body)
(every dipped? optimized-vals))])
(if all-exprs-were-dipped
(let* ([val-deps (apply append (map get-dipped-deps optimized-vals))]
[new-deps (union-id-lists
(diff-id-lists (get-dipped-deps optimized-body)
flattened-bindings)
val-deps)]
[lowered-body (get-dipped-expr optimized-body)]
[lowered-vals (map get-dipped-expr optimized-vals)])
#`(dip #,new-deps
(LET-VALUES #,(map list bindings lowered-vals)
#,lowered-body)))
#`(LET-VALUES #,(map list bindings optimized-vals)
#,optimized-body)))]
[(letrec-syntaxes+values SYNTAX-STUFF ((IDS VALS) ...) EXPR ...)
(let* ([optimized-vals
(map (lambda (e)
(recursively-optimize-expr e equiv-map #f))
(syntax->list #'(VALS ...)))]
[optimized-bindings
(map list (syntax->list #'(IDS ...)) optimized-vals)]
[body #`(begin EXPR ...)]
[optimized-body (recursively-optimize-expr body equiv-map #f)])
#`(letrec-syntaxes+values SYNTAX-STUFF #,optimized-bindings #,optimized-body))]
[(if . ARGS)
(let* ([optimized-args (map (lambda (expr)
(recursively-optimize-expr expr equiv-map #f))
(syntax->list #'ARGS))]
[all-args-were-dipped (every dipped? optimized-args)])
(if all-args-were-dipped
;; we can dip the entire subexpression
(let ([deps (apply union-id-lists (map get-dipped-deps optimized-args))]
[lowered-args (map get-dipped-expr optimized-args)])
#`(dip #,deps (if . #,lowered-args)))
;; we can't dip the entire subexpression, but we may have been able
;; to optimize some of the args.
#`(if . #,optimized-args)))]
;; frtime's if expands into a complicated expression involving super-lift.
;; recognize this pattern, and treat it like an if statement.
[(#%app super-lift
(lambda (_B) (if (#%app undefined? __B)
(begin undefined)
(if ___B
TRUE-CASE
FALSE-CASE)))
(#%app _TO_BOOLEAN CONDITIONAL))
(let* ([optimized-condition (recursively-optimize-expr #'CONDITIONAL equiv-map #f)]
[optimized-true-case (recursively-optimize-expr #'TRUE-CASE equiv-map #f)]
[optimized-false-case (recursively-optimize-expr #'FALSE-CASE equiv-map #f)])
(if (and (dipped? optimized-condition)
(dipped? optimized-true-case)
(dipped? optimized-false-case))
(let ([lowered-condition (get-dipped-expr optimized-condition)]
[lowered-true-case (get-dipped-expr optimized-true-case)]
[lowered-false-case (get-dipped-expr optimized-false-case)]
[deps (union-id-lists (get-dipped-deps optimized-condition)
(get-dipped-deps optimized-true-case)
(get-dipped-deps optimized-false-case))])
#`(dip #,deps (if #,lowered-condition #,lowered-true-case #,lowered-false-case)))
#`(frtime:if #,optimized-condition
#,optimized-true-case
#,optimized-false-case)))]
[(#%app dont-optimize EXPR)
#'EXPR]
[(#%app FUNC . ARGS)
(identifier? #'FUNC)
(let* ([lowered-equiv (lookup-lowered-equiv equiv-map #'FUNC)]
[optimized-args (map (lambda (expr)
(recursively-optimize-expr expr equiv-map #f))
(syntax->list #'ARGS))]
[all-args-were-dipped (every dipped? optimized-args)])
(if (and lowered-equiv all-args-were-dipped)
;; we can dip the entire subexpression
(let ([deps (apply union-id-lists (map get-dipped-deps optimized-args))]
[lowered-args (map get-dipped-expr optimized-args)])
#`(dip #,deps (#%app #,lowered-equiv #,@lowered-args)))
;; we can't dip the entire subexpression, but we may have been able
;; to optimize some of the args.
#`(#%app FUNC #,@optimized-args)))]
;; first-class functions -- we have no idea what function is being called,
;; so we can't optimize it. But try to optimize the subexpressions.
[(#%app FUNC ARG ...)
#`(#%app #,(recursively-optimize-expr #'FUNC equiv-map #f)
#,@(map (lambda (expr)
(recursively-optimize-expr expr equiv-map #f))
(syntax->list #'(ARG ...))))]
;; units expand into complicated code that uses set! to define identifiers.
;; Since we don't support set!, we optimize units based on their *unexpanded*
;; syntax, which is much easier to work with.
[(unit IMPORTS EXPORTS EXPRS ...)
#`(unit IMPORTS EXPORTS
(optimize-module #,(equiv-map-to-stx equiv-map) EXPRS ...))]
[(unit/sig SIG IMPORTS (rename RENAMES ...) EXPRS ...)
#`(unit/sig SIG IMPORTS (rename RENAMES ...)
(optimize-module #,(equiv-map-to-stx equiv-map) EXPRS ...))]
[(unit/sig SIG IMPORTS EXPRS ...)
#`(unit/sig SIG IMPORTS
(optimize-module #,(equiv-map-to-stx equiv-map) EXPRS ...))]
[ELSE
(raise-syntax-error #f
(format "recursively-lower-expr: unrecognized syntax: ~a" (syntax-object->datum stx))
stx)]))
;; Optimize a single expression. Raises exn:fail:syntax if the optimized version
;; would use a protected identifier in an uncertified context.
(define-for-syntax (optimize-expr-helper stx equiv-map allow-lambda)
;; Expand everything but references to identifiers, and units.
;; References to identifiers can't be expanded because they might not be
;; defined yet, in which case we'll get a syntax error. Units can't be
;; expanded because they expand into highly indirect code that uses set!
;; to define structures, and we don't support set! -- so instead we handle
;; units explicitly.
(let* ([expanded-stx (local-expand stx 'top-level (list #'#%top #'unit #'unit/sig))]
[optimized-stx (recursively-optimize-expr expanded-stx equiv-map allow-lambda)])
;; expand the result so that if we happen to have a reference to a
;; protected identifier in an uncertified context, then we can
;; trigger an exception, thus giving us the chance to rollback our
;; changes and return the original code unmodified.
(local-expand optimized-stx 'top-level (list #'#%top)) ;; expand units, too
;; return the unexpanded result, so that callers can figure out whether
;; the expression was completely dipped or not.
optimized-stx))
;; Macro to optimize a single expression. The expression will be dipped
;; wherever possible, and its observable semantics will remain unchanged.
(define-syntax (optimize-expr stx)
(syntax-case stx ()
[(_ EQUIV-MAP EXPR)
(with-handlers ([exn:fail:syntax?
(lambda (exn)
#`(begin #,(exn-message exn) EXPR))])
(let* ([equiv-map (stx-to-equiv-map #'EQUIV-MAP)])
(optimize-expr-helper #'EXPR equiv-map #f)))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Definitions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; returns multiple values:
;; * new equiv map
;; * optimized value
;; * lowered equiv id (or #f if unlowerable)
;; * lowered equiv value (or #f if unlowerable)
(define-for-syntax (optimize-definition-helper equiv-map id val)
(with-handlers
([exn:fail:syntax? (lambda (exn)
(values equiv-map
#`(begin #,(exn-message exn) #,val)
#f
#f))])
(let* ([lowered-equiv-id (make-lowered-equiv-id id)]
[new-equiv-map (add-equiv-map equiv-map id lowered-equiv-id)]
[lowered-val (optimize-expr-helper val new-equiv-map #t)])
(if (and (dipped? lowered-val)
(null? (get-dipped-deps lowered-val)))
;; use new-equiv-map in order to allow the dipped version to call
;; the lowered version for recursive calls.
(let ([optimized-val (optimize-expr-helper val new-equiv-map #f)])
(values new-equiv-map
optimized-val
lowered-equiv-id
(get-dipped-expr lowered-val)))
;; use the old equiv-map, since there is no lowered version so the
;; dipped version can't call it
(let ([optimized-val (optimize-expr-helper val equiv-map #f)])
(values equiv-map
optimized-val
#f
#f))))))
;; Optimize a top-level variable binding, by lowering its value.
(define-syntax (optimize-definition stx)
(syntax-case stx (define-values values)
[(_ EQUIV-MAP (define-values (ID) VAL) FORMS ...)
;; if this is a lowered equiv definition, add it to our equiv map
(lowered-equiv-id? #'ID)
(let ([lifted-id (lowered-equiv-id->lifted-id #'ID)])
#`(begin
(define-values (ID) VAL)
(optimize-module ((#,lifted-id ID) . EQUIV-MAP) FORMS ...)))]
[(_ EQUIV-MAP (define-values (ID) VAL) FORMS ...)
;; We're defining a single identifier
(let-values ([(new-equiv-map optimized-val lowered-equiv-id lowered-val)
(optimize-definition-helper (stx-to-equiv-map #'EQUIV-MAP)
#'ID
#'VAL)])
(if (and lowered-equiv-id lowered-val)
#`(begin
(define ID #,optimized-val)
(define #,lowered-equiv-id #,lowered-val)
(optimize-module #,(equiv-map-to-stx new-equiv-map) FORMS ...))
#`(begin
(define ID #,optimized-val)
(optimize-module #,(equiv-map-to-stx new-equiv-map) FORMS ...))))]
[(_ EQUIV-MAP (define-values (ID ...) (values VAL ...)) FORMS ...)
(= (length (syntax->list #'(ID ...)))
(length (syntax->list #'(VAL ...))))
;; Very common special case: the multiple identifiers are immediately combined
;; with multiple values. Common enough that it's worth handling specially.
(let ([new-equiv-map (stx-to-equiv-map #'EQUIV-MAP)]
[ids null]
[vals null])
(for-each (lambda (id val)
(let-values ([(em optimized-val lowered-equiv-id lowered-val)
(optimize-definition-helper new-equiv-map id val)])
(set! new-equiv-map em)
(when (and lowered-equiv-id lowered-val)
(set! ids (cons lowered-equiv-id ids))
(set! vals (cons lowered-val vals)))
(set! ids (cons id ids))
(set! vals (cons optimized-val vals))))
(syntax->list #'(ID ...))
(syntax->list #'(VAL ...)))
#`(begin
(define-values #,ids (values . #,vals))
(optimize-module #,(equiv-map-to-stx new-equiv-map) FORMS ...)))]
[(_ EQUIV-MAP (define-values (ID ...) EXPR) FORMS ...)
;; We're binding multiple identifiers with some arbitrary set of values,
;; so we can't define lowered-equivs because we can't tease apart the
;; various values. So just optimize the value expression as a whole.
#`(begin
(define-values (ID ...) (optimize-expr EQUIV-MAP EXPR))
(optimize-module EQUIV-MAP FORMS ...))]))
)

115
collects/frtime/lowered-equivs.ss Normal file
View File

@ -0,0 +1,115 @@
;; This module defines all the logic necessary for working with lowered
;; equivalents at the syntactic level. That is, it treats functions simply
;; as syntactic identifiers.
(module lowered-equivs mzscheme
(provide (all-defined))
(require (lib "list.ss"))
(require (only (lib "1.ss" "srfi") any))
(define lowered-equiv-suffix ":lowered-equiv")
;; Given an identifier for a normal binding, return the identifier
;; to be used for the lowered equivalent of that binding.
(define (make-lowered-equiv-id id-stx)
(datum->syntax-object
id-stx
(string->symbol
(format "~a~a" (syntax-e id-stx) lowered-equiv-suffix))))
;; does the given string end with the given suffix?
(define (string-ends-with str suffix)
(string=? (substring str (max 0 (- (string-length str)
(string-length suffix))))
suffix))
;; is the given identifier a lowered equiv identifier?
(define (lowered-equiv-id? id-stx)
(and (identifier? id-stx)
(string-ends-with (symbol->string (syntax-e id-stx))
lowered-equiv-suffix)))
;; strip the lowered-equiv suffix from an identifier
(define (lowered-equiv-id->lifted-id id-stx)
(let ([name (symbol->string (syntax-e id-stx))])
(datum->syntax-object
id-stx
(string->symbol
(substring name 0 (- (string-length name)
(string-length lowered-equiv-suffix)))))))
;; Exception used to indicate that an expression cannot be lowered because
;; it has no lowered equivalent.
(define-struct exn:no-lowered-equiv (reason))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Equiv maps translate function names to the name of a lowered equivalent.
;; Equiv maps are represented as a list of (func . lowered-equiv) pairs.
;; empty equiv map
(define (empty-equiv-map)
(list))
;; add a new func/lowered-equiv mapping to an equiv map (overwrites any
;; existing mapping)
(define (add-equiv-map old-equiv-map new-func new-lowered-func)
(cons (cons new-func new-lowered-func)
old-equiv-map))
;; remove a func/lowered-equiv mapping from an equiv map (no effect if
;; the func isn't actually in the mapping)
(define (del-equiv-map old-equiv-map func-to-remove)
(filter (lambda (pair)
(not (module-identifier=? (car pair) func-to-remove)))
old-equiv-map))
;; remove a list of funcs from an equiv map
(define (del-equiv-map* old-equiv-map ids-to-remove)
(foldl del-equiv-map old-equiv-map ids-to-remove))
;; Returns the lowered-equiv for a function, or #f if there is none.
(define (lookup-lowered-equiv equiv-map func)
(if (null? equiv-map)
#f
(if (module-identifier=? (caar equiv-map) func)
(cdar equiv-map)
(lookup-lowered-equiv (cdr equiv-map) func))))
;; Returns the lowered-equiv for a function, or throws exn:no-lowered-equiv.
(define (get-lowered-equiv equiv-map func)
(let ([ret (lookup-lowered-equiv equiv-map func)])
(if ret
ret
(raise (make-exn:no-lowered-equiv
(format "no lowered equiv for ~s" (syntax-object->datum func)))))))
;; convert syntax of the form ((func lowered-equiv) ...) to an equiv map
(define (stx-to-equiv-map stx)
(syntax-case stx ()
(() (empty-equiv-map))
(((lifted lowered) rest ...)
(add-equiv-map (stx-to-equiv-map #'(rest ...)) #'lifted #'lowered))))
;; convert an equiv map to syntax of the form ((func lowered-equiv) ...)
(define (equiv-map-to-stx equiv-map)
(datum->syntax-object #'here
(map (lambda (pair) (list (car pair) (cdr pair)))
equiv-map)))
;; combine two equiv maps
(define (union-equiv-maps . equiv-maps)
(apply append equiv-maps))
;; convert a list of symbols to an equiv map, by searching for symbols
;; that have a matching lowered equivalent symbol. All other symbols
;; are ignored.
(define (symbol-list-to-equiv-map symbol-list)
(foldl (lambda (func equiv-map)
(if (lowered-equiv-id? func)
(add-equiv-map
equiv-map
(lowered-equiv-id->lifted-id func) func)
equiv-map))
(empty-equiv-map)
symbol-list))
)

16
collects/frtime/mzscheme-core.ss
View File

@ -32,8 +32,8 @@
; (syntax-rules () ; (syntax-rules ()
; [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)])) ; [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)]))
(define (->boolean x) (define (frp:->boolean x)
(if x #t #f)) (lift #t (lambda (x) (if x #t #f)) x))
(define-syntax frp:if (define-syntax frp:if
(syntax-rules () (syntax-rules ()
@ -49,12 +49,12 @@
[(undefined? b) undef-exp] [(undefined? b) undef-exp]
[b then-exp] [b then-exp]
[else else-exp])) [else else-exp]))
(lift #t ->boolean test-exp))])) (frp:->boolean test-exp))]))
(define (copy-list lst) (define (frp:copy-list lst)
(frp:if (null? lst) (frp:if (null? lst)
() ()
(frp:cons (frp:car lst) (copy-list (frp:cdr lst))))) (frp:cons (frp:car lst) (frp:copy-list (frp:cdr lst)))))
(define-syntax frp:let-values (define-syntax frp:let-values
(syntax-rules () (syntax-rules ()
@ -78,7 +78,7 @@
(let ([the-rest-arg (get-rest-arg #'bindings)]) (let ([the-rest-arg (get-rest-arg #'bindings)])
(if the-rest-arg (if the-rest-arg
#`(bindings #`(bindings
(let ([#,the-rest-arg (copy-list #,the-rest-arg)]) (let ([#,the-rest-arg (frp:copy-list #,the-rest-arg)])
body0 body1 ...)) body0 body1 ...))
#'(bindings body0 body1 ...)))])) #'(bindings body0 body1 ...)))]))
@ -426,4 +426,6 @@
(rename frp:make-struct-field-mutator make-struct-field-mutator) (rename frp:make-struct-field-mutator make-struct-field-mutator)
(rename frp:define-struct define-struct) (rename frp:define-struct define-struct)
(rename frp:provide provide) (rename frp:provide provide)
(rename frp:require require))) (rename frp:require require)
frp:copy-list
frp:->boolean))

20
collects/frtime/mzscheme-utils.ss
View File

@ -267,6 +267,12 @@
(loop (cdr lst) (cons (car lst) acc)) (loop (cdr lst) (cons (car lst) acc))
acc))) acc)))
;; This do-nothing function is only here so that frtime programs can
;; mark segments of code that shouldn't be optimized in the frtime-opt
;; language. Ironically, frtime-opt has its *own* definition of this
;; function; this one is just for source compatibility.
(define (dont-optimize x) x)
(provide cond (provide cond
and and
or or
@ -298,7 +304,7 @@
equal? eqv? < > <= >= equal? eqv? < > <= >=
add1 cos sin tan symbol->string symbol? add1 cos sin tan symbol->string symbol?
number->string string->symbol eof-object? exp expt even? odd? string-append eval ; list-ref number->string string->symbol eof-object? exp expt even? odd? string-append eval ; list-ref
sub1 sqrt not number? string? zero? min max modulo sub1 sqrt not number? string string? zero? min max modulo
string->number void? rational? char? char-upcase char-ci>=? char-ci<=? string->number void? rational? char? char-upcase char-ci>=? char-ci<=?
string>=? char-upper-case? char-alphabetic? string>=? char-upper-case? char-alphabetic?
string<? string-ci=? string-locale-ci>? string<? string-ci=? string-locale-ci>?
@ -319,7 +325,7 @@
seconds->date seconds->date
expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks
exn:fail? regexp-match exn:fail? regexp-match
list->vector make-vector) vector->list list->vector make-vector)
(rename eq? mzscheme:eq?) (rename eq? mzscheme:eq?)
make-exn:fail current-inspector make-inspector make-exn:fail current-inspector make-inspector
@ -332,7 +338,7 @@
error set! printf fprintf current-error-port for-each void error set! printf fprintf current-error-port for-each void
procedure-arity-includes? raise-type-error raise thread procedure-arity-includes? raise-type-error raise thread
current-continuation-marks current-continuation-marks
raise-mismatch-error require-for-syntax define-syntax syntax-rules syntax-case raise-mismatch-error require-for-syntax define-syntax define-syntaxes syntax-rules syntax-case
; set-eventspace ; set-eventspace
;install-errortrace-key ;install-errortrace-key
(lifted:nonstrict format) (lifted:nonstrict format)
@ -359,9 +365,12 @@
current-security-guard current-security-guard
make-security-guard make-security-guard
dynamic-require dynamic-require
path? complete-path? absolute-path? relative-path? path-string?
path->complete-path path->complete-path
string->path string->path path->string
split-path bytes->path path->bytes
split-path simplify-path normal-case-path expand-path resolve-path
path-replace-suffix
current-directory current-directory
exit exit
system-type system-type
@ -377,6 +386,7 @@
with-input-from-file with-input-from-file
read read
dont-optimize
; null ; null
; make-struct-field-mutator ; make-struct-field-mutator