diff options
Diffstat (limited to 'csc/ir2.csc')
| -rw-r--r-- | csc/ir2.csc | 104 |
1 files changed, 49 insertions, 55 deletions
diff --git a/csc/ir2.csc b/csc/ir2.csc index 40109fe..7aea0a3 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -1,5 +1,10 @@ (define-library (csc ir2) (export + %apply + %branch + %closure + %fix + %primitive apply-arguments apply-procedure apply? @@ -37,10 +42,12 @@ make-kargs make-klabel make-ktail - make-update - update-atom - update-continuation - update-ref + make-primitive + primitive-arguments + primitive-continuation + primitive-operation + primitive-results + primitive? ; Re-exports from IR1. constant-expression @@ -80,7 +87,8 @@ loop return) (only (csc match) - define-match-record-type)) + define-match-record-type + match)) (begin ; This library defines the intermediate representation IR2. ; It's CPS time bitch. @@ -92,26 +100,6 @@ ; - constant, ; - lexical-ref, ; - or library-ref - ; After closure conversion, lexical refs are no longer allowed. - ; Lexical refs are converted to one of the below data types. - - - ; A variable representing the address of a function in the same compilation - ; unit. This will be a constant after linking. - (define-match-record-type <label> - (make-label gensym) - label? - %label - (gensym label-gensym)) - - - ; A local variable. This can be an argument to a function or the result of - ; a primitive. - (define-match-record-type <var> - (make-var gensym) - var? - %var - (gensym var-gensym)) ; CPS expressions: @@ -120,14 +108,21 @@ ; And they take a continuation. - ; Modifies a library or lexically bound variable to the given atom. - (define-match-record-type <update> - (make-update ref atom continuation) - update? - %update - (ref update-ref) - (atom update-atom) - (continuation update-continuation)) + ; A primitive encodes one of a number of primitive operations. + ; Each operation takes a number of arguments, + ; and binds some number of result variables. + ; The known primitives are listed below, along with their arity. + ; - alloc: size -> result + ; - peek: pointer * offset -> result + ; - poke: word * pointer * offset -> () + (define-match-record-type <primitive> + (make-primitive operation arguments results continuation) + primitive? + %primitive + (operation primitive-operation) + (arguments primitive-arguments) + (results primitive-results) + (continuation primitive-continuation)) ; Branches depending on the given atom. @@ -190,28 +185,27 @@ (define (ir2=?-sametype x y) - (cond - ((and (update? x) (update? y)) - (and (ir1=? (update-ref x) (update-ref y)) - (ir1=? (update-atom x) (update-atom y)) - (ir2=? (update-continuation x) (update-continuation y)))) - ((and (branch? x) (branch? y)) - (and (ir1=? (branch-atom x) (branch-atom 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 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))) + (match (cons x y) + (((% %primitive x-oper x-args x-res x-cont) . (% %primitive y-oper y-args y-res y-cont)) + (and (symbol=? x-oper y-oper) + (= (length x-args) (length y-args)) + (all ir1=? x-args y-args) + (= (length x-res) (length y-res)) + (all ir1=? x-res y-res) + (ir2=? x-cont y-cont))) + (((% %branch x-atom x-true x-false) . (% %branch y-atom y-true y-false)) + (and (ir1=? x-atom y-atom) + (ir2=? x-true y-true) + (ir2=? x-false y-false))) + (((% %apply x-proc x-args) . (% %apply y-proc y-args)) + (and (ir1=? x-proc y-proc) + (= (length x-args) (length y-args)) + (all ir1=? x-args y-args))) + (((% %fix x-funs x-body) . (% %fix y-funs y-body)) + (and (= (length x-funs) (length y-funs)) + (all closure=? x-funs y-funs) + (ir2=? x-body y-body))) + (_ #f))) (define (ir2=? x y) |