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

continuing to work on module paths

Browse Source
This commit is contained in:
Danny Yoo 2011-05-13 17:15:20 -04:00
parent db302a1b0c
commit fee35c3860
8 changed files with 151 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
compiler.rkt
View File

@ -147,7 +147,9 @@
[(PrimitiveKernelValue? exp)
'()]
[(VariableReference? exp)
(loop (VariableReference-toplevel exp) cenv)])))
(loop (VariableReference-toplevel exp) cenv)]
[(Require? exp)
'()])))
@ -270,7 +272,9 @@
[(PrimitiveKernelValue? exp)
(compile-primitive-kernel-value exp cenv target linkage)]
[(VariableReference? exp)
(compile-variable-reference exp cenv target linkage)]))
(compile-variable-reference exp cenv target linkage)]
[(Require? exp)
(compile-require exp cenv target linkage)]))
@ -339,6 +343,14 @@
after-module-body))))
(: compile-require (Require CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-require exp cenv target linkage)
(end-with-linkage linkage cenv
(append-instruction-sequences
(compile-module-invoke (Require-path exp))
(make-instruction-sequence
`(,(make-AssignImmediateStatement target (make-Const (void))))))))
(: compile-module-invoke (ModuleName -> InstructionSequence))
;; Generates code that will invoke a module (if it hasn't been invoked yet)
@ -357,8 +369,9 @@
;; TODO: raise an exception here that says that the module hasn't been
;; linked yet.
,(make-DebugPrint (make-Const
(format "DEBUG: the module ~a hasn't been linked in yet!"
(format "DEBUG: the module ~a hasn't been linked in!!!"
(ModuleName-name a-module-name))))
,(make-GotoStatement (make-Label already-loaded))
,linked
,(make-TestAndBranchStatement (make-TestTrue
(make-IsModuleInvoked a-module-name))
@ -2233,4 +2246,6 @@
[(VariableReference? exp)
(make-VariableReference
(ensure-toplevelref
(adjust-expression-depth (VariableReference-toplevel exp) n skip)))]))
(adjust-expression-depth (VariableReference-toplevel exp) n skip)))]
[(Require? exp)
exp]))

8
expression-structs.rkt
View File

@ -29,7 +29,9 @@
DefValues
PrimitiveKernelValue
Module
VariableReference))
VariableReference
Require))
(define-struct: Provided ([name : Symbol]
@ -87,7 +89,7 @@
;; We may have more information about the lambda's name. This will show it.
(define-struct: LamPositionalName ([name : Symbol]
[path : String]
[path : String] ;; the source of the name
[line : Natural]
[column : Natural]
[offset : Natural]
@ -147,7 +149,7 @@
(define-struct: VariableReference ([toplevel : ToplevelRef]) #:transparent)
(define-struct: Require ([path : ModuleName]) #:transparent)

3
lexical-structs.rkt
View File

@ -17,7 +17,8 @@
;; A ModuleName is an identifier for a Module.
(define-struct: ModuleName ([name : Symbol])
(define-struct: ModuleName ([name : Symbol]
[real-path : (U Symbol Path)])
#:transparent)

114
parse-bytecode-5.1.1.rkt
View File

@ -7,13 +7,16 @@
syntax/modresolve)
;; Parsing Racket 5.1.1 bytecode structures into our own.
;; Parsing Racket 5.1.1 bytecode structures into our own structures.
(require compiler/zo-parse
racket/match
racket/list)
(provide parse-bytecode
current-module-path-index-resolver
;current-module-path-index-resolver
;current-module-path-resolver
current-module-path
reset-lam-label-counter!/unit-testing)
@ -33,6 +36,13 @@
(resolve-module-path-index mpi relative-to)]))))
(define current-module-path-resolver
(make-parameter
(lambda (module-path relative-to)
(resolve-module-path module-path relative-to))))
(define (self-module-path-index? mpi)
(let-values ([(x y) (module-path-index-split mpi)])
(and (eq? x #f)
@ -150,9 +160,16 @@
(define (wrap-module-name resolved-path-name)
(cond
[(symbol? resolved-path-name)
(make-ModuleName resolved-path-name)]
(make-ModuleName resolved-path-name resolved-path-name)]
[(path? resolved-path-name)
(make-ModuleName (rewrite-path resolved-path-name))]))
(let ([rewritten-path (rewrite-path resolved-path-name)])
(cond
[(symbol? rewritten-path)
(make-ModuleName (rewrite-path resolved-path-name) resolved-path-name)]
[else
(error 'wrap-module-name "Unable to resolve module path ~s" resolved-path-name)]))]))
@ -199,8 +216,53 @@
(make-Constant (void)))
(define (parse-req form)
(error 'fixme-req))
(let ([resolver (current-module-path-resolver)])
(match form
[(struct req (reqs dummy))
(let ([require-statement (parse-req-reqs reqs)])
(match require-statement
[(list '#%require (and (? module-path?) path))
(let ([resolved-path ((current-module-path-resolver) path (current-module-path))])
(cond
[(symbol? resolved-path)
(make-Require (make-ModuleName resolved-path resolved-path))]
[(path? resolved-path)
(let ([rewritten-path (rewrite-path resolved-path)])
(cond
[(symbol? rewritten-path)
(make-Require (make-ModuleName rewritten-path resolved-path))]
[else
(printf "Internal error: I don't know how to handle the require for ~s" require-statement)
(error 'parse-req)]))]
[else
(printf "Internal error: I don't know how to handle the require for ~s" require-statement)
(error 'parse-req)]))]
[else
(printf "Internal error: I don't know how to handle the require for ~s" require-statement)
(error 'parse-req)]))])))
;; parse-req-reqs: (stx -> (listof ModuleName))
(define (parse-req-reqs reqs)
(match reqs
[(struct stx (encoded))
(unwrap-wrapped encoded)]))
(define (unwrap-wrapped encoded)
(cond [(wrapped? encoded)
(match encoded
[(struct wrapped (datum wraps certs))
(unwrap-wrapped datum)])]
[(pair? encoded)
(cons (unwrap-wrapped (car encoded))
(unwrap-wrapped (cdr encoded)))]
[(null? encoded)
null]
[else
encoded]))
;; parse-seq: seq -> Expression
@ -209,6 +271,7 @@
[(struct seq (forms))
(make-Seq (map parse-form-item forms))]))
;; parse-form-item: (U form Any) -> Expression
(define (parse-form-item item)
(cond
@ -247,18 +310,23 @@
(cond
[(symbol? self-path)
(make-Module name
(make-ModuleName self-path)
(make-ModuleName self-path self-path)
(parse-prefix prefix)
(parse-mod-requires self-modidx requires)
(parse-mod-provides provides)
(parse-mod-body body))]
[else
(make-Module name
(make-ModuleName (rewrite-path self-path))
(parse-prefix prefix)
(parse-mod-requires self-modidx requires)
(parse-mod-provides provides)
(parse-mod-body body))]))]))
(let ([rewritten-path (rewrite-path self-path)])
(cond
[(symbol? rewritten-path)
(make-Module name
(make-ModuleName rewritten-path self-path)
(parse-prefix prefix)
(parse-mod-requires self-modidx requires)
(parse-mod-provides provides)
(parse-mod-body body))]
[else
(error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))]))
;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleName)
@ -411,14 +479,30 @@
[(vector? name)
(match name
[(vector (and (? symbol?) sym)
(and (? path?) path)
(and (? path?) source)
(and (? number?) line)
(and (? number?) column)
(and (? number?) offset)
(and (? number?) span)
_)
(let ([try-to-rewrite (rewrite-path source)])
(make-LamPositionalName sym
(if try-to-rewrite
(symbol->string try-to-rewrite)
(path->string source))
line
column
offset
span))]
[(vector (and (? symbol?) sym)
(and (? symbol?) source)
(and (? number?) line)
(and (? number?) column)
(and (? number?) offset)
(and (? number?) span)
_)
(make-LamPositionalName sym
(path->string path)
(symbol->string source)
line
column
offset
@ -509,6 +593,8 @@
(define (parse-topsyntax expr)
;; We should not get into this because we're only parsing the runtime part of
;; the bytecode.
(error 'fixme-topsyntax))

2
parse.rkt
View File

@ -52,7 +52,7 @@
[(current-language)
=> (lambda (lang)
(if (member sym lang)
(make-ModuleVariable sym (make-ModuleName '#%kernel))
(make-ModuleVariable sym (make-ModuleName '#%kernel '#%kernel))
#f))]
[else
#f]))

15
path-rewriter.rkt
View File

@ -26,18 +26,14 @@
;; The path rewriter takes paths and provides a canonical symbol for it.
;; Paths located within collects get remapped to collects/....
;; Paths located within collects get remapped to collects, those within
;; the compiler directory mapped to "js-vm", those within the root to "root".
;; If none of these work, we return #f.
;; rewrite-path: path -> (symbol #f)
(define (rewrite-path a-path)
(let ([a-path (normalize-path a-path)])
(cond
[(within-root? a-path)
(string->symbol
(string-append "root/"
(path->string
(find-relative-path (current-root-path) a-path))))]
[(within-collects? a-path)
(string->symbol
(string-append "collects/"
@ -48,6 +44,11 @@
(string-append "js-vm/"
(path->string
(find-relative-path this-normal-path a-path))))]
[(within-root? a-path)
(string->symbol
(string-append "root/"
(path->string
(find-relative-path (current-root-path) a-path))))]
[else
#f])))

19
test-parse-bytecode-5.1.1.rkt
View File

@ -377,21 +377,18 @@
(run-my-parse #'(case-lambda [(x) x]
[(x y) (list x y)])))
;; make sure we don't see an infinite loop
#;(run-zo-parse #'(letrec ([g (lambda () (g))])
(g)))
(run-my-parse #'(letrec ([g (lambda () (g))])
(g)))
;; todo: add tests to make sure we're parsing this as expected. We expect to see an EmptyClosureReference here.
(void
(run-my-parse #'(letrec ([g (lambda () (g))])
(g))))
#;(run-zo-parse #'(letrec ([g (lambda () (h))]
[h (lambda () (g))])
(g)))
;; FIXME: we need to handle closure cycles here.
(void
(run-my-parse #'(letrec ([g (case-lambda [() (g)]
[(x y) (g x y)])])
(g))))

16
test-parse.rkt
View File

@ -208,7 +208,7 @@
'lamEntry2)))
(test (parse '(+ x x))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel))
x))
(make-App (make-ToplevelRef 2 0)
(list (make-ToplevelRef 2 1)
@ -216,7 +216,7 @@
(test (parse '(lambda (x) (+ x x)))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel))))
(make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel))))
(make-Lam 'unknown 1 #f
(make-App (make-ToplevelRef 2 0)
(list (make-LocalRef 3 #f)
@ -226,8 +226,8 @@
(test (parse '(lambda (x)
(+ (* x x) x)))
(make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel))
,(make-ModuleVariable '+ (make-ModuleName '#%kernel))))
(make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel '#%kernel))
,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel))))
(make-Lam 'unknown 1 #f
;; stack layout: [???, ???, prefix, x]
(make-App (make-ToplevelRef 2 1)
@ -286,7 +286,7 @@
(test (parse '(let* ([x 3]
[x (add1 x)])
(add1 x)))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel))))
;; stack layout: [prefix]
@ -415,7 +415,7 @@
(test (parse '(let ([x 0])
(lambda ()
(set! x (add1 x)))))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel))))
(make-Let1 (make-Constant 0)
(make-BoxEnv 0
(make-Lam 'unknown 0 #f
@ -434,7 +434,7 @@
[y 1])
(lambda ()
(set! x (add1 x)))))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel))))
(make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel))))
(make-LetVoid 2
(make-Seq (list
(make-InstallValue 1 0 (make-Constant 0) #t)
@ -462,7 +462,7 @@
(reset!)
(list a b)))
(make-Top
(make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel)) reset!))
(make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel '#%kernel)) reset!))
(make-Splice
(list
(make-ToplevelSet 0 0 (make-Constant '(hello)))