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

Changed the base language to allow for a list of conventions.

Browse Source 
Changed the base language foregin and fcallable forms to accept a list of
conventions, which are each symbols, instead of a single convention, which was
a list of conventions, mostly to make it clear in the grammar what is going on.
  base-lang.ss, cp0.ss cpcheck.ss, cpcommonize.ss, cpletrec.ss, cpnanopass.ss,
  cprep.ss, cpvalid.ss, interpret.ss, syntax.ss,

Fixed a place where we were checking for eq? of two conventions, which now
should be equal? since it is a list (assuming this list will always be in a
consistent order).
  cpcommonize.ss

Removed a spurious definition of convention?
  np-languages.ss

original commit: dabf5a8abeaef12cdfcb36d9aac236dda9ac9158
This commit is contained in:
Andy Keep 2018-04-07 15:18:27 -04:00 committed by Matthew Flatt
parent 7c94235f6b
commit 9f78570343
11 changed files with 60 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
s/base-lang.ss
View File

@ -155,7 +155,7 @@
(define convention?
(lambda (x)
(and (list? x) (andmap symbol? x))))
(symbol? x)))
(define-record-type preinfo
(nongenerative #{preinfo e23pkvo5btgapnzomqgegm-2})
@ -211,7 +211,7 @@
; source language used by the passes leading up to the compiler or interpreter
(define-language Lsrc
(nongenerative-id #{Lsrc czsa1fcfzdeh493n-2})
(nongenerative-id #{Lsrc czsa1fcfzdeh493n-3})
(terminals
(preinfo (preinfo))
($prelex (x))
@ -248,8 +248,8 @@
(record-ref rtd type index e)
(record-set! rtd type index e1 e2)
(cte-optimization-loc box e)
(foreign conv name e (arg-type* ...) result-type)
(fcallable conv e (arg-type* ...) result-type)
(foreign (conv ...) name e (arg-type* ...) result-type)
(fcallable (conv ...) e (arg-type* ...) result-type)
(profile src) => (profile)
; used only in cpvalid
(cpvalid-defer e))

36
s/cp0.ss
View File

@ -949,13 +949,13 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))]
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]
[(record-type ,rtd ,e) (memoize (pure? e))]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]
[(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))]
[(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (pure? e))]
[(moi) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(pariah) #t]
[else ($oops who "unrecognized record ~s" e)]))))
@ -1008,13 +1008,13 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory? e))]
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))]
[(record-type ,rtd ,e) (memoize (ivory? e))]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))]
[(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))]
[(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (ivory? e))]
[(moi) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(pariah) #t]
[else ($oops who "unrecognized record ~s" e)]))))
@ -1052,14 +1052,14 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple? e))]
[(record-ref ,rtd ,type ,index ,e) (memoize (simple? e))]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[(record-type ,rtd ,e) (memoize (simple? e))]
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple? rtd-expr) (andmap simple? e*)))]
[(pariah) #f]
[(profile ,src) #f]
[(cte-optimization-loc ,box ,e) (memoize (simple? e))]
[(moi) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[else ($oops who "unrecognized record ~s" e)]))))
(define-who simple/profile?
@ -1097,14 +1097,14 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile? e))]
[(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile? e))]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[(record-type ,rtd ,e) (memoize (simple/profile? e))]
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile? rtd-expr) (andmap simple/profile? e*)))]
[(pariah) #t]
[(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (simple/profile? e))]
[(moi) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[else ($oops who "unrecognized record ~s" e)]))))
(define-who boolean-valued?
@ -1137,8 +1137,8 @@
[(profile ,src) #f]
[(set! ,maybe-src ,x ,e) #f]
[(moi) #f]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) #f]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) #f]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) #f]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) #f]
[(pariah) #f]
[else ($oops who "unrecognized record ~s" e)])))))
@ -2058,8 +2058,8 @@
[(set! ,maybe-src ,x0 ,e0) (list e)]
[(case-lambda ,preinfo ,cl* ...) (list e)]
[,pr (list e)]
[(foreign ,conv ,name ,e0 (,arg-type* ...) ,result-type) (list e)]
[(fcallable ,conv ,e0 (,arg-type* ...) ,result-type) (list e)]
[(foreign (,conv ...) ,name ,e0 (,arg-type* ...) ,result-type) (list e)]
[(fcallable (,conv ...) ,e0 (,arg-type* ...) ,result-type) (list e)]
[(record-type ,rtd0 ,e0) (list e)]
[(record-cd ,rcd0 ,rtd-expr0 ,e0) (list e)]
[(immutable-list (,e0* ...) ,e0) (list e)]
@ -3363,8 +3363,8 @@
(nanopass-case (Lsrc Expr) xres
[(case-lambda ,preinfo ,cl ...) #t]
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) #t]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) #t]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) #t]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #t]
[(immutable-list (,e* ...) ,e) #t]
[else #f])))
@ -4609,13 +4609,13 @@
true-rec
(begin (bump sc 1) pr))]
[(app) (fold-primref pr ctxt sc wd name moi)])]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type)
(context-case ctxt
[(value app) (bump sc 1) `(foreign ,conv ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(value app) (bump sc 1) `(foreign (,conv ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type)
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type)
(context-case ctxt
[(value app) (bump sc 1) `(fcallable ,conv ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(value app) (bump sc 1) `(fcallable (,conv ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(effect) (cp0 e 'effect env sc wd #f moi)]
[(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])]
[(record ,rtd ,rtd-expr ,e* ...)

8
s/cpcheck.ss
View File

@ -130,11 +130,11 @@
[(set! ,maybe-src ,x ,[e #f -> e]) `(set! ,maybe-src ,x ,e)]
[(seq ,[e1 #f -> e1] ,[e2]) `(seq ,e1 ,e2)]
[(if ,[e1 #f -> e1] ,[e2 #f -> e2] ,[e3 #f -> e3]) `(if ,e1 ,e2 ,e3)]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type)
(check! ctxt (list (length arg-type*)))
`(foreign ,conv ,name ,(Expr e #f) (,arg-type* ...) ,result-type)]
[(fcallable ,conv ,[e #f -> e] (,arg-type* ...) ,result-type)
`(fcallable ,conv ,e (,arg-type* ...) ,result-type)]
`(foreign (,conv ...) ,name ,(Expr e #f) (,arg-type* ...) ,result-type)]
[(fcallable (,conv ...) ,[e #f -> e] (,arg-type* ...) ,result-type)
`(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type)]
[(call ,preinfo0
(case-lambda ,preinfo1
(clause (,x* ...) ,interface ,body)

24
s/cpcommonize.ss
View File

@ -73,10 +73,10 @@
(values `(seq ,e1 ,e2) (fx+ size1 size2))]
[(if ,[e1 size1] ,[e2 size2] ,[e3 size3])
(values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))]
[(foreign ,conv ,name ,[e size] (,arg-type* ...) ,result-type)
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
[(fcallable ,conv ,[e size] (,arg-type* ...) ,result-type)
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
[(foreign (,conv ...) ,name ,[e size] (,arg-type* ...) ,result-type)
(values `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
[(fcallable (,conv ...) ,[e size] (,arg-type* ...) ,result-type)
(values `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
; ($top-level-value 'x) adds just 1 to the size
[(call ,preinfo ,pr (quote ,d))
(guard (eq? (primref-name pr) '$top-level-value))
@ -379,24 +379,24 @@
(with-env x1* x2*
`(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))]
[else #f])]
[(foreign ,conv1 ,name1 ,e1 (,arg-type1* ...) ,result-type1)
[(foreign (,conv1 ...) ,name1 ,e1 (,arg-type1* ...) ,result-type1)
(nanopass-case (Lcommonize1 Expr) e2
[(foreign ,conv2 ,name2 ,e2 (,arg-type2* ...) ,result-type2)
(and (eq? conv1 conv2)
[(foreign (,conv2 ...) ,name2 ,e2 (,arg-type2* ...) ,result-type2)
(and (equal? conv1 conv2)
(equal? name1 name2)
(fx= (length arg-type1*) (length arg-type2*))
(andmap same-type? arg-type1* arg-type2*)
(same-type? result-type1 result-type2)
`(foreign ,conv1 ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
`(foreign (,conv1 ...) ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])]
[(fcallable ,conv1 ,e1 (,arg-type1* ...) ,result-type1)
[(fcallable (,conv1 ...) ,e1 (,arg-type1* ...) ,result-type1)
(nanopass-case (Lcommonize1 Expr) e2
[(fcallable ,conv2 ,e2 (,arg-type2* ...) ,result-type2)
(and (eq? conv1 conv2)
[(fcallable (,conv2 ...) ,e2 (,arg-type2* ...) ,result-type2)
(and (equal? conv1 conv2)
(fx= (length arg-type1*) (length arg-type2*))
(andmap same-type? arg-type1* arg-type2*)
(same-type? result-type1 result-type2)
`(fcallable ,conv1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
`(fcallable (,conv1 ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])]
[(cte-optimization-loc ,box1 ,e1)
(nanopass-case (Lcommonize1 Expr) e2

8
s/cpletrec.ss
View File

@ -348,11 +348,11 @@ Handling letrec and letrec*
(with-initialized-ids x*
(lambda (x*)
(cpletrec-letrec #t x* e* body)))]
[(foreign ,conv ,name ,[e pure?] (,arg-type* ...) ,result-type)
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
[(foreign (,conv ...) ,name ,[e pure?] (,arg-type* ...) ,result-type)
(values `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))]
[(fcallable ,conv ,[e pure?] (,arg-type* ...) ,result-type)
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type)
[(fcallable (,conv ...) ,[e pure?] (,arg-type* ...) ,result-type)
(values `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))]
[(record-ref ,rtd ,type ,index ,[e pure?])
(values `(record-ref ,rtd ,type ,index ,e) #f)]

4
s/cpnanopass.ss
View File

@ -1045,11 +1045,11 @@
[(call ,preinfo ,e ,[e*] ...)
`(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (fx< (optimize-level) 3) #f #f)
,(Expr e) ,e* ...)]
[(foreign ,conv ,name ,[e] (,arg-type* ...) ,result-type)
[(foreign (,conv ...) ,name ,[e] (,arg-type* ...) ,result-type)
(let ([info (make-info-foreign conv arg-type* result-type)])
(info-foreign-name-set! info name)
`(foreign ,info ,e))]
[(fcallable ,conv ,[e] (,arg-type* ...) ,result-type)
[(fcallable (,conv ...) ,[e] (,arg-type* ...) ,result-type)
`(fcallable ,(make-info-foreign conv arg-type* result-type) ,e)])
(CaseLambdaExpr ir #f))

4
s/cprep.ss
View File

@ -187,11 +187,11 @@
[(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 (,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)
[(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))]

16
s/cpvalid.ss
View File

@ -328,10 +328,10 @@
(let-values ([(e* vals-dl?) (undefer* e* proxy dl?)])
(defer-or-not (or body-dl? vals-dl?)
`(letrec* ([,x* ,e*] ...) ,body)))]
[(foreign ,conv ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable ,conv ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable ,conv ,e (,arg-type* ...) ,result-type))]
[(foreign (,conv ...) ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable (,conv ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[undefer : e dl?])
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
[(pariah) (values x #f)]
@ -547,10 +547,10 @@
(defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))]
[(seq ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?])
(defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))]
[(foreign ,conv ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable ,conv ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable ,conv ,e (,arg-type* ...) ,result-type))]
[(foreign (,conv ...) ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable (,conv ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[cpvalid : e dl?])
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
[(pariah) (values x #f)]

8
s/interpret.ss
View File

@ -459,7 +459,7 @@
[(seq ,e1 ,e2)
(let ((e1 (ip2 e1)) (e2 (ip2 e2)))
($rt lambda () ($rt e1) ($rt e2)))]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
[(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
@ -468,11 +468,11 @@
(with-output-language (Lsrc Expr)
`(case-lambda ,(make-preinfo-lambda)
(clause (,t) 1
(foreign ,conv ,name (ref #f ,t)
(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)
[(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
@ -481,7 +481,7 @@
(with-output-language (Lsrc Expr)
`(case-lambda ,(make-preinfo-lambda)
(clause (,t) 1
(fcallable ,conv (ref #f ,t) (,arg-type* ...) ,result-type))))))])
(fcallable (,conv ...) (ref #f ,t) (,arg-type* ...) ,result-type))))))])
(let ([e (ip2 e)])
($rt lambda () ((p) ($rt e)))))]
[else (unexpected-record x)])))

4
s/np-languages.ss
View File

@ -78,10 +78,6 @@
(import (nanopass))
(include "base-lang.ss")
; convention is a list of symbols (we're assuming the front end already verified
; the convention is a valid one for this machine-type)
(define convention? (lambda (x) (and (list? x) (andmap symbol? x))))
; r6rs says a quote subform should be a datum, not must be a datum
; chez scheme allows a quote subform to be any value
(define datum? (lambda (x) #t))

4
s/syntax.ss
View File

@ -689,14 +689,14 @@
(define build-foreign-procedure
(lambda (ae conv foreign-name foreign-addr params result)
(build-profile ae
`(foreign ,conv ,foreign-name ,foreign-addr
`(foreign (,conv ...) ,foreign-name ,foreign-addr
(,(map (lambda (x) (build-fp-specifier 'foreign-procedure 'parameter x #f)) params) ...)
,(build-fp-specifier 'foreign-procedure "result" result #t)))))
(define build-foreign-callable
(lambda (ae conv proc params result)
(build-profile ae
`(fcallable ,conv ,proc
`(fcallable (,conv ...) ,proc
(,(map (lambda (x) (build-fp-specifier 'foreign-callable 'parameter x #f)) params) ...)
,(build-fp-specifier 'foreign-callable "result" result #t))))))