diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt new file mode 100644 index 0000000..79b13d6 --- /dev/null +++ b/bootstrapped-primitives.rkt @@ -0,0 +1,68 @@ +#lang typed/racket/base +(require "expression-structs.rkt" + "lexical-structs.rkt" + "il-structs.rkt" + "lexical-env.rkt" + "helpers.rkt" + "find-toplevel-variables.rkt" + "sets.rkt" + "compile.rkt" + racket/list) + +(provide call/cc-label + make-call/cc-code) + + + +;; The primitive code necessary to do call/cc + +(: call/cc-label Symbol) +(define call/cc-label 'callCCEntry) +(define call/cc-closure-entry 'callCCClosureEntry) + + +;; (call/cc f) +;; Tail-calls f, providing it a special object that knows how to do the low-level +;; manipulation of the environment and control stack. +(define (make-call/cc-code) + (statements + (append-instruction-sequences + (make-instruction-sequence + `(,call/cc-label + ;; Precondition: the environment holds the f function that we want to jump into. + + ;; First, move f to the proc register + ,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f)) + + ;; Next, capture the envrionment and the current continuation closure,. + ,(make-PushEnvironment 2 #f) + ,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) + (make-CaptureControl 0)) + ,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f) + ;; When capturing, skip over f and the two slots we just added. + (make-CaptureEnvironment 3)) + ,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2) + (make-MakeCompiledProcedure call/cc-closure-entry + 1 ;; the continuation consumes a single value + (list (make-EnvLexicalReference 0 #f) + (make-EnvLexicalReference 1 #f)) + 'call/cc)) + ,(make-PopEnvironment 2 0))) + + ;; Finally, do a tail call into f. + (compile-procedure-call '() + (extend-lexical-environment/placeholders '() 1) + 1 + 'val + 'return) + + ;; The code for the continuation coe follows. It's supposed to + ;; abandon the current continuation, initialize the control and environment, and then jump. + (make-instruction-sequence `(,call/cc-closure-entry + ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) + ,(make-PerformStatement (make-InstallClosureValues!)) + ,(make-PerformStatement (make-RestoreControl!)) + ,(make-PerformStatement (make-RestoreEnvironment!)) + ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) + ,(make-PopControlFrame) + ,(make-GotoStatement (make-Reg 'proc))))))) diff --git a/compile.rkt b/compile.rkt index b379ef2..0d8416a 100644 --- a/compile.rkt +++ b/compile.rkt @@ -12,9 +12,7 @@ (provide (rename-out [-compile compile]) compile-procedure-call append-instruction-sequences - - call/cc-label - make-call/cc-code) + adjust-target-depth) (: current-defined-name (Parameterof (U Symbol False))) @@ -32,10 +30,7 @@ exp) (list) target - linkage) - (make-instruction-sequence `(,(make-GotoStatement (make-Label end)))) - (make-call/cc-code) - end)))) + linkage))))) @@ -652,61 +647,3 @@ (error 'ensure-natural "Not a natural: ~s\n" n))) - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;; The primitive code necessary to do call/cc - -(: call/cc-label Symbol) -(define call/cc-label 'callCCEntry) -(define call/cc-closure-entry 'callCCClosureEntry) - - -;; (call/cc f) -;; Tail-calls f, providing it a special object that knows how to do the low-level -;; manipulation of the environment and control stack. -(define (make-call/cc-code) - (append-instruction-sequences - (make-instruction-sequence - `(,call/cc-label - ;; Precondition: the environment holds the f function that we want to jump into. - - ;; First, move f to the proc register - ,(make-AssignImmediateStatement 'proc (make-EnvLexicalReference 0 #f)) - - ;; Next, capture the envrionment and the current continuation closure,. - ,(make-PushEnvironment 2 #f) - ,(make-AssignPrimOpStatement (make-EnvLexicalReference 0 #f) - (make-CaptureControl 0)) - ,(make-AssignPrimOpStatement (make-EnvLexicalReference 1 #f) - ;; When capturing, skip over f and the two slots we just added. - (make-CaptureEnvironment 3)) - ,(make-AssignPrimOpStatement (adjust-target-depth (make-EnvLexicalReference 0 #f) 2) - (make-MakeCompiledProcedure call/cc-closure-entry - 1 ;; the continuation consumes a single value - (list (make-EnvLexicalReference 0 #f) - (make-EnvLexicalReference 1 #f)) - (current-defined-name))) - ,(make-PopEnvironment 2 0))) - - ;; Finally, do a tail call into f. - (compile-procedure-call '() - (extend-lexical-environment/placeholders '() 1) - 1 - 'val - 'return) - - ;; The code for the continuation coe follows. It's supposed to - ;; abandon the current continuation, initialize the control and environment, and then jump. - (make-instruction-sequence `(,call/cc-closure-entry - ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) - ,(make-PerformStatement (make-InstallClosureValues!)) - ,(make-PerformStatement (make-RestoreControl!)) - ,(make-PerformStatement (make-RestoreEnvironment!)) - ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) - ,(make-PopControlFrame) - ,(make-GotoStatement (make-Reg 'proc)))))) diff --git a/package.rkt b/package.rkt index 83aba0d..3bafb4a 100644 --- a/package.rkt +++ b/package.rkt @@ -4,6 +4,7 @@ "assemble.rkt" "typed-parse.rkt" "il-structs.rkt" + "bootstrapped-primitives.rkt" racket/runtime-path racket/port) @@ -21,8 +22,7 @@ (for-each (lambda (code) (displayln code op)) (map assemble-basic-block - (fracture (statements - (make-call/cc-code))))) + (fracture (make-call/cc-code)))) ;; The runtime code (call-with-input-file* runtime.js diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 6eefa7c..d04e449 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "simulator-structs.rkt" "compile.rkt" + "bootstrapped-primitives.rkt" racket/math (for-syntax racket/base)) diff --git a/simulator.rkt b/simulator.rkt index 1267fec..7e2b793 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -7,6 +7,7 @@ (require "il-structs.rkt" "simulator-structs.rkt" + "bootstrapped-primitives.rkt" racket/list racket/match (for-syntax racket/base)) @@ -30,15 +31,27 @@ (: new-machine ((Listof Statement) -> machine)) (define (new-machine program-text) - (let: ([m : machine (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0 - ((inst make-hash Symbol Natural)))]) - (let: loop : Void ([i : Natural 0]) - (when (< i (vector-length (machine-text m))) - (let: ([stmt : Statement (vector-ref (machine-text m) i)]) - (when (symbol? stmt) - (hash-set! (machine-jump-table m) stmt i)) - (loop (add1 i))))) - m)) + (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)] + [program-text : (Listof Statement) + (append `(,(make-GotoStatement (make-Label after-bootstrapping))) + (make-call/cc-code) + `(,after-bootstrapping) + program-text)]) + (let: ([m : machine (make-machine (make-undefined) + (make-undefined) + '() + '() + 0 + (list->vector program-text) + 0 + ((inst make-hash Symbol Natural)))]) + (let: loop : Void ([i : Natural 0]) + (when (< i (vector-length (machine-text m))) + (let: ([stmt : Statement (vector-ref (machine-text m) i)]) + (when (symbol? stmt) + (hash-set! (machine-jump-table m) stmt i)) + (loop (add1 i))))) + m))) diff --git a/test-assemble.rkt b/test-assemble.rkt index aed1711..4541a2c 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -5,6 +5,7 @@ "parse.rkt" "il-structs.rkt" "compile.rkt" + "bootstrapped-primitives.rkt" racket/port racket/promise racket/runtime-path) @@ -45,8 +46,7 @@ ;; The support code for call/cc (string-join (map assemble-basic-block - (fracture (statements - (make-call/cc-code)))) + (fracture (make-call/cc-code))) "\n") runtime @@ -70,8 +70,7 @@ (display (string-join (map assemble-basic-block - (fracture (statements - (make-call/cc-code)))) + (fracture (make-call/cc-code))) "\n") op) diff --git a/test-browser-evaluate.rkt b/test-browser-evaluate.rkt index f3f0ae3..8c5982a 100644 --- a/test-browser-evaluate.rkt +++ b/test-browser-evaluate.rkt @@ -20,7 +20,6 @@ #'stx))) (printf " ok (~a milliseconds)\n" (evaluated-t result))))))])) -#| (test '(begin (define (f x) (if (= x 0) 0 @@ -142,7 +141,7 @@ (displayln (tak 18 12 6))) "7\n") -|# -(test (read (open-input-file "tests/conform/program1.sch")) + +#;(test (read (open-input-file "tests/conform/program0.sch")) (port->string (open-input-file "tests/conform/expected0.txt"))) \ No newline at end of file