diff options
Diffstat (limited to 'csc/ir2.csc')
| -rw-r--r-- | csc/ir2.csc | 161 |
1 files changed, 61 insertions, 100 deletions
diff --git a/csc/ir2.csc b/csc/ir2.csc index 1872b65..9b9397f 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -1,5 +1,8 @@ (define-library (csc ir2) (export + apply-arguments + apply-procedure + apply? atom-continuation atom-expression atom? @@ -10,9 +13,14 @@ call-closure-args call-closure-closure call-closure? - closure-cases - closure-continuation + closure-arguments + closure-body + closure-name + closure-rest closure? + fix-body + fix-functions + fix? ir2=? kargs-expression kargs-refs @@ -20,18 +28,15 @@ klabel-expression klabel? ktail? - lambda-args-kargs - lambda-args-nargs - lambda-args-rest - lambda-args? + make-apply make-atom make-branch make-call-closure make-closure + make-fix make-kargs make-klabel make-ktail - make-lambda-args make-update update-atom update-continuation @@ -91,23 +96,6 @@ ; but constrained not to have any subexpressions except atoms. ; And they take a continuation. - ; CPS continuations - ; There are a few continuations. - ; Continuations are identified by an integer ID into the - ; continuation map. - ; Guile calls this map the "continuation soup". - - - ; CPS expressions. - - - ; An atom consists of an atom and a continuation. - (define-record-type <atom> - (make-atom expression continuation) - atom? - (expression atom-expression) - (continuation atom-continuation)) - ; Modifies a library or lexically bound variable to the given atom. (define-record-type <update> @@ -118,7 +106,7 @@ (continuation update-continuation)) - ; Evaluates the given atom. + ; Branches depending on the given atom. ; If it is true, continue with continuation true. ; If false, continue with continuation false. (define-record-type <branch> @@ -129,99 +117,72 @@ (false branch-false)) - ; Calls the given closure. Closure is an atom, and args is a list of atoms. - (define-record-type <call-closure> - (make-call-closure closure args continuation) - call-closure? - (closure call-closure-closure) - (args call-closure-args) - (continuation call-closure-continuation)) - + ; Applies a procedure to a list of arguments. Apply does not take a + ; continuation. Instead the continuation will be passed as the first + ; argument to the function. + (define-record-type <apply> + (make-apply procedure arguments) + apply? + (procedure apply-procedure) + (arguments apply-arguments)) - ; One branch of a case-lambda. nargs encodes the number of required - ; arguments, and rest is a boolean indicating whether the function takes a - ; rest parameter. kargs is a continuation ID pointing to a - ; kargs continuation. - (define-record-type <lambda-args> - (make-lambda-args nargs rest kargs) - lambda-args? - (nargs lambda-args-nargs) - (rest lambda-args-rest) - (kargs lambda-args-kargs)) - - ; A lambda expression. + ; A procedure. All closures are allocated in a fix expression. A closure + ; does not take a continuation. Instead, the procedure will accept the + ; continuation as an argument. (define-record-type <closure> - (make-closure cases continuation) + (make-closure name arguments rest body) closure? - (cases closure-cases) - (continuation closure-continuation)) - - - ; CPS continuations. - - - ; The tail continuation. - (define-record-type <ktail> - (make-ktail) - ktail?) + (name closure-name) + (arguments closure-arguments) + (rest closure-rest) + (body closure-body)) - ; Binds the incoming values to the given lexically-bound variables - ; and then evaluates expression. - (define-record-type <kargs> - (make-kargs refs expression) - kargs? - (refs kargs-refs) - (expression kargs-expression)) + ; Defines a list of mutually recursive procedures. + ; Functions is a list of closures, and body is an expression. + (define-record-type <fix> + (make-fix functions body) + fix? + (functions fix-functions) + (body fix-body)) - ; Ignores any incoming values and evaluates the given expression. - (define-record-type <klabel> - (make-klabel expression) - klabel? - (expression klabel-expression)) + (define (closure=? x y) + (let ((x-args (closure-arguments x)) + (x-rest (closure-rest x)) + (y-args (closure-arguments y)) + (y-rest (closure-rest y))) + (and (ir1=? (closure-name x) (closure-name y)) + (= (length x-args) (length y-args)) + (all ir1=? x-args y-args) + (or (and (not x-rest) (not y-rest)) + (and x-rest y-rest (ir1=? x-rest y-rest))) + (ir2=? (closure-body x) (closure-body y))))) (define (ir2=?-sametype x y) (cond - ((and (atom? x) (atom? y)) - (and (ir1=? (atom-expression x) (atom-expression y)) - (= (atom-continuation x) (atom-continuation y)))) ((and (update? x) (update? y)) (and (ir1=? (update-ref x) (update-ref y)) (ir1=? (update-atom x) (update-atom y)) - (= (update-continuation x) (update-continuation y)))) + (ir2=? (update-continuation x) (update-continuation y)))) ((and (branch? x) (branch? y)) (and (ir1=? (branch-atom x) (branch-atom y)) - (= (branch-true x) (branch-true y)) - (= (branch-false x) (branch-false y)))) - ((and (call-closure? x) (call-closure? y)) - (let ((x-args (call-closure-args x)) - (y-args (call-closure-args y))) - (and (ir1=? (call-closure-closure x) (call-closure-closure y)) + (ir2=? (branch-true x) (branch-true y)) + (ir2=? (branch-false x) (branch-false y)))) + ((and (apply? x) (apply? y)) + (let ((x-args (apply-arguments x)) + (y-args (apply-arguments y))) + (and (ir1=? (apply-procedure x) (apply-procedure y)) (= (length x-args) (length y-args)) - (all (lambda (x) x) (map ir1=? x-args y-args)) - (= (call-closure-continuation x) (call-closure-continuation y))))) - ((and (lambda-args? x) (lambda-args? y)) - (and (= (lambda-args-nargs x) (lambda-args-nargs y)) - (boolean=? (lambda-args-rest x) (lambda-args-rest y)) - (= (lambda-args-kargs x) (lambda-args-kargs y)))) - ((and (closure? x) (closure? y)) - (let ((x-cases (closure-cases x)) - (y-cases (closure-cases y))) - (and (= (length x-cases) (length y-cases)) - (all (lambda (x) x) (map ir2=? x-cases y-cases)) - (= (closure-continuation x) (closure-continuation y))))) - ((and (ktail? x) (ktail? y)) #t) - ((and (kargs? x) (kargs? y)) - (let ((x-refs (kargs-refs x)) - (y-refs (kargs-refs y))) - (and (= (length x-refs) (length y-refs)) - (all (lambda (x) x) (map ir1=? x-refs y-refs)) - (ir2=? (kargs-expression x) (kargs-expression y))))) - ((and (klabel? x) (klabel? y)) - (ir2=? (klabel-expression x) (klabel-expression y))) + (all ir1=? x-args y-args)))) + ((and (fix? x) (fix? y)) + (let ((x-funs (fix-functions x)) + (y-funs (fix-functions y))) + (and (= (length x-funs) (length y-funs)) + (all closure=? x-funs y-funs) + (ir2=? (fix-body x) (fix-body y))))) (else #f))) |