Skip to content

Commit

Permalink
add recursive apply rules and another normalization for comp
Browse files Browse the repository at this point in the history
  • Loading branch information
@chsasank
chsasank committed Mar 5, 2024
1 parent c528435 commit a7b1b60
Show file tree
Hide file tree
Showing 2 changed files with 85 additions and 40 deletions.
61 changes: 42 additions & 19 deletions src/rewrite.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,36 +40,45 @@
:rhs '(for-loop ?i ?g ?h (comp ?f ?E)))

;; Normalize comps for faster converge`nce
(defun normalize-comps-step (prog)
(defun normalize-comp-step (prog)
"Heuristic to make further analysis easy.
Ideally should be derivable from above."
(if (not (listp prog))
prog
(let* ((comp-pat '(comp (?* ?start-comp)
(comp (?* ?inside-comp))
(?* ?end-comp)))
(binding (pat-match comp-pat prog)))
(if binding
`(comp ,@(cdr (assoc '?start-comp binding))
,@(cdr (assoc '?inside-comp binding))
,@(cdr (assoc '?end-comp binding)))
; try recursively if failed
(mapcar #'normalize-comps prog)))))
(let ((binding-simple (pat-match '(comp ?inside-comp) prog)))
(if binding-simple
(cdr (assoc 'inside-comp binding-simple))
; try yet another pattern
(let* ((comp-pat '(comp (?* ?start-comp)
(comp (?* ?inside-comp))
(?* ?end-comp)))
(binding (pat-match comp-pat prog)))
(if binding
`(comp ,@(cdr (assoc '?start-comp binding))
,@(cdr (assoc '?inside-comp binding))
,@(cdr (assoc '?end-comp binding)))

; try recursively if this too failed
(mapcar #'normalize-comp-step prog)))))))

(defun normalize-comps (prog)
(defun normalize-comp (prog)
"Iteratively apply normalize step until prog converges"
(let ((old-prog prog)
(new-prog (normalize-comps-step prog)))
(new-prog (normalize-comp-step prog)))
(loop while (not (equal new-prog old-prog))
do (setf old-prog new-prog)
do (setf new-prog (normalize-comps-step old-prog)))
do (setf new-prog (normalize-comp-step old-prog)))
new-prog))

(defun check-if-comp-based-rule (rule)
"Check if rule is comp based"
(eq (first (first rule)) 'comp))

(defun apply-comp-based-rule (rule prog)
"Apply composition based rules.
Heursitic to speed up search.
Normalize prog for best performance"
(if (not (eq (first (first rule)) 'comp))
(if (not (check-if-comp-based-rule rule))
(error "rule ~a doesn't start with comp" rule))

(let* ((comp-pat `(comp (?* ?start-comp)
Expand All @@ -82,7 +91,21 @@
,@(cdr (assoc '?end-comp binding)))
prog)))

(defun rewrite-program (prog rule)
(let ((bindings (pat-match (first rewrite-rule) prog)))
(if bindings
(sublis bindings (second rewrite-rule)))))
(defun apply-rule (rule prog)
(if (check-if-comp-based-rule rule)
(apply-comp-based-rule rule prog)
(let ((bindings (pat-match (first rewrite-rule) prog)))
(if bindings
(sublis bindings (second rewrite-rule)))
prog)))

(defun apply-rule-recursively (rule prog)
(if (not (listp prog))
prog
(let ((new-prog (apply-rule rule prog)))
(if (equal new-prog prog)
; don't give up yet
(mapcar #'(lambda (subprog)
(apply-rule-recursively rule subprog))
prog)
new-prog))))
64 changes: 43 additions & 21 deletions src/rewrite.test.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,39 +8,61 @@
(for-loop i2 (const 0) (comp len (idx 0))
(comp (idx i2) (idx i1)))))

(defvar *test-cases* '(
(trace normalize-comp)

(defvar *test-cases* `(
; function, expected value
((normalize-comps '(alpha g))
((normalize-comp '(alpha g))
(alpha g))

((normalize-comps '(comp (comp f g) h))
((normalize-comp '(comp (comp f g) h))
(comp f g h))

((normalize-comps '(comp f1 f2 (comp f3 f4) f5))
((normalize-comp '(comp f1 f2 (comp f3 f4) f5))
(comp f1 f2 f3 f4 f5))

((normalize-comps '(alpha (comp f1 f2 (comp f3 f4) f5)))
((normalize-comp '(alpha (comp f1 f2 (comp f3 f4) f5)))
(alpha (comp f1 f2 f3 f4 f5)))

((normalize-comps '(comp f1 (comp f2 (comp f3 f4) f5)))
((normalize-comp '(comp f1 (comp f2 (comp f3 f4) f5)))
(comp f1 f2 f3 f4 f5))

((normalize-comps '(comp g (alpha (comp f1 (comp f2 (comp f3 f4) f5)))))
((normalize-comp '(comp g (alpha
(comp f1 (comp f2 (comp f3 f4) f5)))))
(comp g (alpha (comp f1 f2 f3 f4 f5))))

((normalize-comps (fl-expand '(comp IP C-IP)))
(comp (insert add) (alpha mul) trans
(for-loop i1 (const 0) (const 2)
(for-loop i2 (const 0) (comp len (idx 0))
(comp (idx i2) (idx i1))))))

((apply-comp-based-rule (fl-rewrite "2-53")
'(comp (insert add) (alpha mul)
(for-loop i1 (const 0)
len (idx i1))))
(comp (insert add)
(for-loop i1 (const 0) len
(comp mul (idx i1)))))
((normalize-comp (fl-expand '(comp IP C-IP)))
(comp (insert add) (alpha mul) trans
(for-loop i1 (const 0) (const 2)
(for-loop i2 (const 0) (comp len (idx 0))
(comp (idx i2) (idx i1))))))

((apply-comp-based-rule (fl-rewrite "2-53")
'(comp (insert add) (alpha mul)
(for-loop i1 (const 0)
len (idx i1))))
(comp (insert add)
(for-loop i1 (const 0) len
(comp mul (idx i1)))))

; without recursion, this rule should fail
((apply-rule (fl-rewrite "2-53")
'(comp (insert add) (comp (alpha f) (for-loop i g h E))))
(comp (insert add) (comp (alpha f) (for-loop i g h E))))

((normalize-comp '(comp (insert add) (comp
(for-loop i g h (comp f E)))))
(comp (insert add) (for-loop i g h (comp f E))))

((normalize-comp (apply-rule-recursively (fl-rewrite "2-53")
'(comp (insert add) (comp (alpha f) (for-loop i g h E)))))
(comp (insert add) (for-loop i g h (comp f E))))

; ((apply-rule-recursively (fl-rewrite "2-53")
; (normalize-comp (fl-expand '(comp IP C-IP))))
; ,(normalize-comp (fl-expand '(comp IP C-IP))))


))

(defun test-driver ()
Expand All @@ -60,7 +82,7 @@
; (let ((prog (fl-expand '(comp IP HY))))
; (print prog)
; (print "Original program")
; (print (normalize-comps prog))
; (print (normalize-comp prog))
; ; (print
; ; (mapcar
; ; #'(lambda (x) (rewrite-program prog x))
Expand Down

0 comments on commit a7b1b60

Please sign in to comment.