diff --git a/assemble.rkt b/assemble.rkt index 5e0257b..58ac2a7 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -354,7 +354,7 @@ EOF ;; during install-closure-values. (reverse (MakeCompiledProcedure-closed-vals op))) ", ") - (symbol->string (MakeCompiledProcedure-label op)))] + (symbol->string (MakeCompiledProcedure-display-name op)))] [(ApplyPrimitiveProcedure? op) (format "MACHINE.proc(~a, ~a)" diff --git a/compile.rkt b/compile.rkt index 8121312..b379ef2 100644 --- a/compile.rkt +++ b/compile.rkt @@ -16,6 +16,11 @@ call/cc-label make-call/cc-code) + +(: current-defined-name (Parameterof (U Symbol False))) +(define current-defined-name (make-parameter #f)) + + ;(provide compile-top) (: -compile (ExpressionCore Target Linkage -> (Listof Statement))) @@ -184,10 +189,11 @@ (error 'compile-definition "Defintion not at toplevel")] [(PrefixAddress? lexical-pos) (let ([get-value-code - (compile (Def-value exp) cenv (make-EnvPrefixReference - (PrefixAddress-depth lexical-pos) - (PrefixAddress-pos lexical-pos)) - 'next)]) + (parameterize ([current-defined-name var]) + (compile (Def-value exp) cenv (make-EnvPrefixReference + (PrefixAddress-depth lexical-pos) + (PrefixAddress-pos lexical-pos)) + 'next))]) (end-with-linkage linkage cenv @@ -255,7 +261,8 @@ `(,(make-AssignPrimOpStatement target (make-MakeCompiledProcedure proc-entry (length (Lam-parameters exp)) - lexical-references))))) + lexical-references + (current-defined-name)))))) (compile-lambda-body exp cenv lexical-references free-vars @@ -489,10 +496,11 @@ (: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-let1 exp cenv target linkage) (let*: ([rhs-code : InstructionSequence - (compile (Let1-rhs exp) - (extend-lexical-environment/placeholders cenv 1) - (make-EnvLexicalReference 0 #f) - 'next)] + (parameterize ([current-defined-name (Let1-name exp)]) + (compile (Let1-rhs exp) + (extend-lexical-environment/placeholders cenv 1) + (make-EnvLexicalReference 0 #f) + 'next))] [after-let1 : Symbol (make-label 'afterLetOne)] [after-body-code : Symbol (make-label 'afterLetBody)] [extended-cenv : CompileTimeEnvironment @@ -526,15 +534,16 @@ (let*: ([n : Natural (length (Let-rhss exp))] [rhs-codes : (Listof InstructionSequence) (map (lambda: ([rhs : ExpressionCore] - [i : Natural]) - (compile rhs - (extend-lexical-environment/placeholders cenv n) - (make-EnvLexicalReference i #f) - 'next)) + [i : Natural] + [name : Symbol]) + (parameterize ([current-defined-name name]) + (compile rhs + (extend-lexical-environment/placeholders cenv n) + (make-EnvLexicalReference i #f) + 'next))) (Let-rhss exp) - (build-list n - (lambda: ([i : Natural]) - i)))] + (build-list n (lambda: ([i : Natural]) i)) + (Let-names exp))] [after-let : Symbol (make-label 'afterLet)] [after-body-code : Symbol (make-label 'afterLetBody)] [extended-cenv : CompileTimeEnvironment @@ -566,16 +575,17 @@ (let*: ([n : Natural (length (LetRec-rhss exp))] [rhs-codes : (Listof InstructionSequence) (map (lambda: ([rhs : ExpressionCore] - [i : Natural]) - (compile rhs - (extend-lexical-environment/boxed-names cenv - (LetRec-names exp)) - (make-EnvLexicalReference i #t) - 'next)) + [i : Natural] + [name : Symbol]) + (parameterize ([current-defined-name name]) + (compile rhs + (extend-lexical-environment/boxed-names cenv + (LetRec-names exp)) + (make-EnvLexicalReference i #t) + 'next))) (LetRec-rhss exp) - (build-list n - (lambda: ([i : Natural]) - i)))] + (build-list n (lambda: ([i : Natural]) i)) + (LetRec-names exp))] [after-letrec : Symbol (make-label 'afterLetRec)] [after-body-code : Symbol (make-label 'afterLetBody)] [extended-cenv : CompileTimeEnvironment @@ -679,7 +689,8 @@ (make-MakeCompiledProcedure call/cc-closure-entry 1 ;; the continuation consumes a single value (list (make-EnvLexicalReference 0 #f) - (make-EnvLexicalReference 1 #f)))) + (make-EnvLexicalReference 1 #f)) + (current-defined-name))) ,(make-PopEnvironment 2 0))) ;; Finally, do a tail call into f. diff --git a/il-structs.rkt b/il-structs.rkt index b5ff080..4a2eada 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -136,7 +136,8 @@ ;; closure needs to close over. (define-struct: MakeCompiledProcedure ([label : Symbol] [arity : Natural] - [closed-vals : (Listof EnvReference)]) + [closed-vals : (Listof EnvReference)] + [display-name : (U Symbol False)]) #:transparent) ;; Applies the primitive procedure that's stored in the proc register, using diff --git a/runtime.js b/runtime.js index e5c9cd4..f3c67db 100644 --- a/runtime.js +++ b/runtime.js @@ -152,6 +152,11 @@ var Primitives = (function() { return firstArg - 1; }, + 'zero?': function(arity, returnLabel) { + var firstArg = MACHINE.env[MACHINE.env.length-1]; + return firstArg === 0; + }, + 'vector': function(arity, returnLabel) { var i; var result = []; diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 5719cdf..087de4e 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -41,7 +41,8 @@ (define call/cc (make-closure call/cc-label 1 - '())) + '() + 'call/cc)) (define call-with-current-continuation call/cc) (define e (exp 1)) @@ -66,6 +67,36 @@ (define my-pair? (lambda (x) (MutablePair? x))) +(define my-box (lambda (x) + (vector x))) + +(define my-unbox (lambda (x) + (vector-ref x 0))) + +(define my-set-box! (lambda (x v) + (vector-set! x 0 v))) + +(define my-vector->list (lambda (v) + (apply my-list (vector->list v)))) + +(define my-list->vector (lambda (l) + (apply vector + (let loop ([l l]) + (cond + [(null? l) + null] + [else + (cons (MutablePair-h l) + (loop (MutablePair-t l)))]))))) + + +(define my-set-car! (lambda (p v) + (set-MutablePair-h! p v))) + +(define my-set-cdr! (lambda (p v) + (set-MutablePair-t! p v))) + + (define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= sub1 display newline displayln @@ -74,6 +105,7 @@ eq? add1 sub1 + zero? abs void quotient @@ -81,14 +113,37 @@ display displayln newline + symbol->string + string-append (my-cons cons) (my-list list) (my-car car) (my-cdr cdr) (my-pair? pair?) + (my-set-car! set-car!) + (my-set-cdr! set-cdr!) + + + + (my-box box) + (my-unbox unbox) + (my-set-box! set-box!) + vector + vector-set! + vector-ref + (my-vector->list vector->list) + (my-list->vector list->vector) + + + + equal? + + + + symbol?) #:constants (null pi e call/cc diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 52e522d..a5d48a3 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -24,7 +24,8 @@ (define-struct: MutablePair ([h : PrimitiveValue] - [t : PrimitiveValue])) + [t : PrimitiveValue]) + #:mutable #:transparent) ;; For continuation capture: (define-struct: CapturedControl ([frames : (Listof frame)])) @@ -70,7 +71,8 @@ ;; Compiled procedure closures (define-struct: closure ([label : Symbol] [arity : Natural] - [vals : (Listof SlotValue)]) + [vals : (Listof SlotValue)] + [display-name : (U Symbol False)]) #:transparent) diff --git a/simulator.rkt b/simulator.rkt index e2b1920..b96550f 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -191,7 +191,9 @@ (if (= (closure-arity clos) (CheckClosureArity!-arity op)) 'ok - (error 'check-closure-arity "arity mismatch"))] + (error 'check-closure-arity "arity mismatch: passed ~s args to ~s" + (CheckClosureArity!-arity op) + (closure-display-name clos)))] [else (error 'check-closure-arity "not a closure: ~s" clos)]))] @@ -263,7 +265,8 @@ (MakeCompiledProcedure-arity op) (map (lambda: ([r : EnvReference]) (lookup-env-reference/closure-capture m r)) - (MakeCompiledProcedure-closed-vals op))))] + (MakeCompiledProcedure-closed-vals op)) + (MakeCompiledProcedure-display-name op)))] [(ApplyPrimitiveProcedure? op) (let: ([prim : SlotValue (machine-proc m)] diff --git a/test-conform.rkt b/test-conform.rkt index 8d63616..5ee9978 100644 --- a/test-conform.rkt +++ b/test-conform.rkt @@ -15,6 +15,8 @@ #:debug? (debug? false) #:stack-limit (stack-limit false) #:control-limit (control-limit false)) + + #;(for-each displayln (vector->list (machine-text m))) (let loop ([steps 0]) (when debug? @@ -49,7 +51,7 @@ (printf "Running... \n") (let*-values([(a-machine num-steps) (run (new-machine (run-compiler code)) options ...)] - [(actual) (machine-val a-machine)]) + [(actual) (machine-val a-machine)]) (unless (equal? actual exp) (raise-syntax-error #f (format "Expected ~s, got ~s" exp actual) #'stx)) @@ -66,4 +68,4 @@ (test (read (open-input-file "tests/conform/program0.sch")) (port->string (open-input-file "tests/conform/expected0.txt")) - #:debug? #t) + #:debug? #f) diff --git a/tests/conform/program0.sch b/tests/conform/program0.sch index 6558e25..8c99991 100644 --- a/tests/conform/program0.sch +++ b/tests/conform/program0.sch @@ -1,4 +1,42 @@ (begin + +(define (caar l) + (car (car l))) + +(define (map f l) + (if (null? l) + null + (cons (f (car l)) + (map f (cdr l))))) + +(define (for-each f l) + (if (null? l) + null + (begin (f (car l)) + (for-each f (cdr l))))) + +(define (memq x l) + (if (null? l) + #f + (if (eq? x (car l)) + l + (memq x (cdr l))))) + + +(define (assq x l) + (if (null? l) + #f + (if (eq? x (caar l)) + (car l) + (assq x (cdr l))))) + + +(define (length l) + (if (null? l) + 0 + (add1 (length (cdr l))))) + + (define vector-copy (lambda (v) (let ((length (vector-length v))) @@ -241,11 +279,11 @@ (define res (lambda (pair) (cdr pair))) (define conforms? (lambda (t1 t2) - (letrec ((nodes-with-red-edges-out '()) + (letrec ((nodes-with-red-edges-out (box '())) (add-red-edge! (lambda (from-node to-node) (set-red-edges! from-node (adjoin to-node (red-edges from-node))) - (set! nodes-with-red-edges-out (adjoin from-node nodes-with-red-edges-out)))) + (set-box! nodes-with-red-edges-out (adjoin from-node (unbox nodes-with-red-edges-out))))) (greenify-red-edges! (lambda (from-node) (set-green-edges! from-node (append (red-edges from-node) (green-edges from-node))) @@ -279,7 +317,7 @@ loop) (blue-edges t2)))))))))) (let ((result (does-conform t1 t2))) - (for-each (if result greenify-red-edges! delete-red-edges!) nodes-with-red-edges-out) + (for-each (if result greenify-red-edges! delete-red-edges!) (unbox nodes-with-red-edges-out)) result)))) (define equivalent? (lambda (a b) (if (conforms? a b) (conforms? b a) '#f))) (define classify @@ -379,7 +417,7 @@ (if (conforms? node2 node1) (begin node2) (begin - (let ((result (make-node (string-append '"(" (name node1) '" v " (name node2) '")")))) + (let ((result (make-node (string-append '"(" (name node1) '" v " (name node2) '")") '()))) (add-graph-nodes! graph result) (insert! (already-joined graph) node1 node2 result) (set-blue-edges! @@ -411,25 +449,25 @@ (begin (if print? (begin (display '" -> ") (display new-count) (newline)) (void)) (loop new-g new-count))))))))) - (let ((graph (apply make-graph (list (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))) + (let ((graph (make-graph (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g))))))) (loop graph (length (graph-nodes graph))))))) -(define a '()) -(define b '()) -(define c '()) -(define d '()) +(define a (box '())) +(define b (box '())) +(define c (box '())) +(define d (box '())) (define reset (lambda () - (set! a (make-node 'a '())) - (set! b (make-node 'b '())) - (set-blue-edges! a (list (make-blue-edge 'phi any-node b))) - (set-blue-edges! b (list (make-blue-edge 'phi any-node a) (make-blue-edge 'theta any-node b))) - (set! c (make-node '"c" '())) - (set! d (make-node '"d" '())) - (set-blue-edges! c (list (make-blue-edge 'theta any-node b))) - (set-blue-edges! d (list (make-blue-edge 'phi any-node c) (make-blue-edge 'theta any-node d))) + (set-box! a (make-node 'a '())) + (set-box! b (make-node 'b '())) + (set-blue-edges! (unbox a) (list (make-blue-edge 'phi any-node (unbox b)))) + (set-blue-edges! (unbox b) (list (make-blue-edge 'phi any-node (unbox a)) (make-blue-edge 'theta any-node (unbox b)))) + (set-box! c (make-node '"c" '())) + (set-box! d (make-node '"d" '())) + (set-blue-edges! (unbox c) (list (make-blue-edge 'theta any-node (unbox b)))) + (set-blue-edges! (unbox d) (list (make-blue-edge 'phi any-node (unbox c)) (make-blue-edge 'theta any-node (unbox d)))) '(made a b c d))) (define test - (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list a b c d any-node none-node)) '#t))))) + (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list (unbox a) (unbox b) (unbox c) (unbox d) any-node none-node)) '#t))))) (define go (lambda () (reset)