analyze.slog

;----------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;APPENDED PROGRAM ABOVE;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;ANALYSIS PROGRAM BELOW;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------;


;----------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;::;;;;PRIM TAGGING::;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------;

;NUMERIC-PRIMS
(numeric-prim "+")
(numeric-prim "-")
(numeric-prim "*")
(numeric-prim "/")
(numeric-prim "=")
(numeric-prim "modulo")


;BOOL-PRIMS
(bool-prim "=")
(bool-prim ">")
(bool-prim "<")
(bool-prim "<=")
(bool-prim ">=")
(bool-prim "null?")
(bool-prim "equal?")
(bool-prim "eq?")


;----------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;FREE VARIABLES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------;
;NON-LIST-VALUES
(non-list-value ?(symbol v) (symbol-val v))
(non-list-value ?(bool v) (bool-val v))
(non-list-value ?(int v) (int-val v))
(non-list-value ?(string v) (string-val v))
(non-list-value ?(state v) (state-val v))


; (non-list-value (or (addr _) (quote _) (string _) (bool _) (state _)))

;REF VARIABLES
(free x ?(ref x))

;LAMBDAS
[(free x eb)
 (=/= y x)
 -->
 (free x ?(lambda (varparam y) eb))]

[(free x eb)
 -->
 (do-free-lam ?(lambda (fixedparam ys) eb) ys x)]

[(do-free-lam lam [y ys ...] x)
 (=/= y x)
 -->
 (do-free-lam lam ys x)]

[(do-free-lam lam [] x)
 -->
 (free x lam)]

;APPL
[(or (free x ef) (free x ea))
 -->
 (free x ?(appl ef ea))]

;IF EXPRESSIONS
[(or (free x guard) (free x tExp) (free x fExp))
 -->
 (free x ?(if guard tExp fExp))]

;APP
[(free x ef)
 -->
 (free x ?(app ef eas))]

(do-free-app ?(app ef eas) eas)

[(do-free-app app [ea eas ...])
 -->
 (do-free-app app eas)
 [(free x ea)
  -->
  (free x app)]]


;LET BINDINGS RIGHT HAND SIDES
(do-free-let-rhs ?(let binds body) binds)

[(do-free-let-rhs let [bind binds ...])
 -->
 (do-free-let-rhs let binds)]

[(do-free-let-rhs let [(binding lhs rhs) binds ...])
 (free x rhs)
 -->
 (free x let)]

;LET BINDINGS LEFT HAND SIDES
[(free x body)
 -->
 (do-free-let-lhs ?(let binds body) binds x)]

[(do-free-let-lhs let [(binding lhs rhs) binds ...] x)
 (=/= lhs x)
 -->
 (do-free-let-lhs let binds x)]

[(do-free-let-lhs let [] x)
 -->
 (free x let)]



;----------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;START RULE;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------;
[(define "brouhaha_main" (fixedparam []) body)
 -->
 (eval body [] (halt))]

(tick ?(do-tick [] call) [call])
(tick ?(do-tick [x] call) [call]) ; for m = 1 uncomment this, comment out the lines below
; (tick ?(do-tick [x] call) [call x]) 
; ; ; (tick ?(do-tick [x _] call) [call x]) ; for m = 2, uncomment this, comment out the lines below
; (tick ?(do-tick [x y] call) [call x y])
; (tick ?(do-tick [x y _] call) [call x y]) ;for m = 3, keeping latest 3-calls


;----------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;EVAL CASES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------;
;BASE PRIMITIVE TYPES
[(eval e ctx kont)
 (= e (symbol val))
 -->
 (store (f-addr ctx "symbol") (symbol-val val))
 (ret (f-addr ctx "symbol") kont)]

[(eval e ctx kont)
 (= e (bool val))
 -->
 (store (f-addr ctx e) (bool-val val))
 (ret (f-addr ctx e) kont)]

[(eval e ctx kont)
 (= e (int val))
 -->
 (store (f-addr ctx "int") (int-val val))
 (ret (f-addr ctx "int") kont)]
 

[(eval e ctx kont)
 (= e (string val))
 -->
 (store (f-addr ctx "string") (string-val val))
 (ret (f-addr ctx "string") kont)]

[(eval e ctx kont)
 (= e (state val))
 -->
 (store (f-addr ctx "state") (state-val val))
 (ret (f-addr ctx "state") kont)]

;FUNCTION AND VARIABLE REFERENCES
[(eval (ref x) ctx kont)
 -->
 (ret (f-addr ctx x) kont)]

;LAMBDA AND FUNC
[(eval e ctx kont)
 (= e (lambda _ _))
 -->
 (store (f-addr ctx "addr-lam") (clo e ctx))
 (ret (f-addr ctx "addr-lam") kont)]

;APP AND APPLY
[(eval call ctx kont)
 (= call (app ef [eas ...]))
 -->
 (eval ef ctx (appk call [] eas ctx kont))]

[(eval call ctx kont)
 (= call (appl ef ea))
 -->
 (eval ef ctx (applak call ea ctx kont))]

;IF CASE
[(eval (if guard tExp fExp) ctx kont)
 -->
 (eval guard ctx (if-k tExp fExp ctx kont))]

;LET CASE
[(eval call ctx kont)
 (= call (let [(binding lhs rhs) bind-rest ...] body))
 -->
 (eval rhs ctx (letk call body [lhs] [] bind-rest ctx kont))]



;---------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;RET CASES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;---------------------------------------------------------------------;
;LAMBDA AND FUNC
[(ret a (appk call [as ...] [ea0 ea-rest ...] ctx kont))
 -->
 (eval ea0 ctx (appk call [as ... a] [ea-rest ...] ctx kont))]

[(ret a (appk call [af as ...] [] ctx kont))
 (store af vf)
 -->
 (apply vf (fixedarg [as ... a]) ctx kont call)]

[(ret af (appk call [] [] ctx kont))
 (store af vf)
 -->
 (apply vf (fixedarg []) ctx kont call)]

[(ret af (applak call ea ctx kont))
 -->
 (eval ea ctx (applfk call af ctx kont))]

[(ret a (applfk call af ctx kont))
 (store af vf)
 -->
 (apply vf (vararg a) ctx kont call)]

[(ret a (k-addr eb))
 -->
 (ret a {store (k-addr eb)})]

;IF CASES
[(ret ga (if-k tExp fExp ctx kont))
 (store ga (bool-val "t"))
 -->
 (eval tExp ctx kont)]

[(ret ga (if-k tExp fExp ctx kont))
 (store ga (bool-val "f"))
 -->
 (eval fExp ctx kont)]

[(ret (s-addr _) (if-k tExp fExp ctx kont))
 -->
 (eval tExp ctx kont)
 (eval fExp ctx kont)]

;LET CASE
[(ret a (letk call body [xs ...] [as ...] [(binding lhs rhs) bind-rest ...] ctx kont))
 -->
 (eval rhs ctx (letk call body [xs ... lhs] [as ... a] bind-rest ctx kont))]

[(ret a (letk call body [xs ...] [as ...] [] ctxlet kont))
 -->
 (= ctxtick {tick !(do-tick ctxlet call)})
 (store (k-addr body) kont)
 (do-fixed-prop-all ctxtick xs [as ... a])
 (eval body ctxtick (k-addr body))

 [(free y body)
  -->
  (store (f-addr ctxtick y) {store (f-addr ctxlet y)})]]


;---------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;APPLY CASES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;---------------------------------------------------------------------;
;DEFINE --> CLOSURE
[(apply (define fname params body) args ctx kont call)
 -->
 (apply (clo (lambda params body) []) args ctx kont call)]

;DEFINE-PRIM HANDLING (NOT SPECIALIZED)
[(apply (define-prim fname _) _ _ kont _)
 (~ specialized-prim fname)
 -->
 (store (s-addr fname) (state-val fname))
 (ret (s-addr fname) kont)]

;  [(= e (apply (define-prim fname _) args _ kont _))
;  (~ specialized-prim fname)
;  -->
;  (store (s-addr e) (state-val e))
;  (ret (s-addr e) kont)]


;SPECIALIZED PRIMS
(specialized-prim "cons")
  [(= e (apply (define-prim "cons" _) (fixedarg [a0 a1]) ctx kont _))
  (store a1 (list-of-vals as))
  -->
  (store (f-addr ctx "addr-cons") (list-of-vals [a0 a1]))
  (ret (f-addr ctx "addr-cons") kont)]

  [(= e (apply (define-prim "cons" _) (fixedarg [a0 a1]) ctx kont _))
  (store a1 val)
  (non-list-value _ val)
  -->
  (store (f-addr ctx "addr-cons") (list-of-vals [a0 a1]))
  (ret (f-addr ctx "addr-cons") kont)]

  ;VARIADIC
  [(= e (apply (define-prim "cons" _) (vararg a) ctx kont call))
  (store a (list-of-vals as))
  --> 
  (do-store-addr-union (f-addr ctx "addr-cons") as [])
  (ret (f-addr ctx "addr-cons") kont)]

  ;When the next address points to a list-of-vals
  [(do-store-addr-union addr [a as ...] [union-as ...])
  (store a (list-of-vals under-as))
  -->
  (do-store-addr-union addr as [a under-as ... union-as ...])]

  ;When the next address points to a single addr
  [(do-store-addr-union addr [a as ...] [union-as ...])
  (store a val)
  (non-list-value _ val)
  -->
  (do-store-addr-union addr as [a union-as])]
 
  [(do-store-addr-union addr [] [union-as ...])
  -->
  (store addr (list-of-vals union-as))]

(specialized-prim "null?")
  [(= e (apply (define-prim "null?" _) (fixedarg [a]) ctx kont _))
   (store a (list-of-vals as))
   (= as [])
   -->
   (store (f-addr ctx "addr-null?") (bool-val "t"))
   (ret (f-addr ctx "addr-null?") kont)]

  [(= e (apply (define-prim "null?" _) (fixedarg [a]) ctx kont _))
   (store a (list-of-vals [a0 as ...]))
   -->
   (store (f-addr ctx "addr-null?") (bool-val "t"))
   (store (f-addr ctx "addr-null?") (bool-val "f"))
   (ret (f-addr ctx "addr-null?") kont)]

  [(= e (apply (define-prim "null?" _) (fixedarg [a]) ctx kont _))
   (store a (state-val val))
   -->
   (store (f-addr ctx "addr-null?") (bool-val "t"))
   (store (f-addr ctx "addr-null?") (bool-val "f"))
   (ret (f-addr ctx "addr-null?") kont)]

   [(= e (apply (define-prim "null?" _) (fixedarg [a]) ctx kont _))
   (store a (int-val val))
   -->
   (store (f-addr ctx "addr-null?") (bool-val "t"))
   (store (f-addr ctx "addr-null?") (bool-val "f"))
   (ret (f-addr ctx "addr-null?") kont)]

(specialized-prim "car")
  [(= e (apply (define-prim "car" _) (fixedarg [a]) ctx kont _))
   (store a (list-of-vals [_ ... ai _ ...]))
   -->
   (store (f-addr ctx "addr-car") {store ai}) 
   (ret (f-addr ctx "addr-car") kont)]

(specialized-prim "cdr")
  [(= e (apply (define-prim "cdr" _) (fixedarg [a]) ctx kont _))
   (store a (list-of-vals as))
   -->
   (store (f-addr ctx "addr-cdr") (list-of-vals as))
   (ret (f-addr ctx "addr-cdr") kont)]

(specialized-prim "list")
 [(= e (apply (define-prim "list" _) (fixedarg as) ctx kont _))
  (=/= as [])
  -->
  (store (f-addr ctx "addr-list") (list-of-vals as))
  (ret (f-addr ctx "addr-list") kont)]

[(= e (apply (define-prim "list" _) (fixedarg as) ctx kont _))
  (= as [])
  -->
  (store (f-addr ctx "addr-list-null") (list-of-vals as))
  (ret (f-addr ctx "addr-list-null") kont)]

 [(= e (apply (define-prim "list" _) (vararg a) ctx kont _))
  (store a (list-of-vals as))
  -->
  (store (f-addr ctx "addr-list") (list-of-vals as))
  (ret (f-addr ctx "addr-list") kont)]

;; ASK ABOUT DO-TICK FOR PRIMS
;; >> We do not need DO-TICK for prims, because their body needs
;; >> no evaluation, thus require no-context meaning no DO-TICK!


;FIXED ARG
[(apply (clo (lambda (fixedparam [xs ...]) eb) ctxlam) (fixedarg [as ...]) ctxcall kont call)
 --> 
 (store (k-addr eb) kont)
 (= ctxtick {tick !(do-tick ctxcall call)})
 (do-fixed-prop-all ctxtick xs as)
 (eval eb ctxtick (k-addr eb))

 [(free y eb)
  -->
  (store (f-addr ctxtick y) {store (f-addr ctxlam y)})
  (store-flow (f-addr ctxtick y) (f-addr ctxlam y))
  ]]

[(apply (clo (lambda (varparam x) eb) ctxlam) (fixedarg [as ...]) ctxcall kont call)
 -->
 (store (k-addr eb) kont)
 (= ctxtick {tick !(do-tick ctxcall call)})
 (store (f-addr ctxtick x) (list-of-vals as))
 (eval eb ctxtick (k-addr eb))

 [(free y eb)
  -->
  (store-flow (f-addr ctxtick y) (f-addr ctxlam y))]]

;VARIADIC ARG
[(apply (clo (lambda (varparam x) eb) ctxlam) (vararg a) ctxcall kont call)
 -->
 (store (k-addr eb) kont)
 (= ctxtick {tick !(do-tick ctxcall call)})
 (store-flow a (f-addr ctxtick x))
 (eval eb ctxtick (k-addr eb))

 [(free y eb)
  -->
  (store-flow (f-addr ctxtick y) (f-addr ctxlam y))]]

[(apply (clo (lambda (fixedparam [xs ...]) eb) ctxlam) (vararg a) ctxcall kont call)
 (store a (list-of-vals as))
 -->
 (store (k-addr eb) kont)
 (= ctxtick {tick !(do-tick ctxcall call)})
 (do-var-prop-all ctxtick xs as)
 (eval eb ctxtick (k-addr eb))

 [(free y eb)
  -->
  (store-flow (f-addr ctxtick y) (f-addr ctxlam y))]]



;----------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;HELPER FUNCTIONS;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------;
;DO-VIXED-PROP-ALL
[(do-fixed-prop-all ctxtick [x x-rest ...] [a a-rest ...])
 -->
 (do-fixed-prop-all ctxtick x-rest a-rest)
 (store (f-addr ctxtick x) {store a})
 (store-flow a (f-addr ctxtick x))]


;DO-VAR-PROP-ALL
[(do-var-prop-all ctxtick [x x-rest ...] [a a-rest ...])
 -->
 (do-var-prop-all-h ctxtick [x x-rest ...] [a a-rest ...] [a a-rest ...])]

[(do-var-prop-all-h ctxtick [x x-rest ...] [a a-rest ...] a-old)
 -->
 (do-var-prop-all-h ctxtick [x x-rest ...] a-rest a-old)
 (store-flow a (f-addr ctxtick x))]


[(do-var-prop-all-h ctxtick [x x-rest ...] [] a-old)
 -->
 (do-var-prop-all-h ctxtick x-rest a-old a-old)]

;STORE-FLOW
[(store a v)
 (store-flow a a1)
 -->
 (store a1 v)]

;DETECTING ANSWER
(answer ?(ret (s-addr a) (halt)) {store (s-addr a)})
(answer ?(ret (f-addr c a) (halt)) {store (f-addr c a)})


;----------------------------------------------------------------------;
;;;;;;;;;;;;;;;;;;;;;;;;;;Inlinable Callsite Detection;;;;;;;;;;;;;;;;;;
;----------------------------------------------------------------------;

; IS DEFINE-PRIM
; [(eval exp _ _)
; (= exp (app (ref func) _))
; (store (f-addr _ func) (define-prim dp_func _))
; (count store (f-addr _ func) (define-prim dp_func _) cnt)
;  -->
; (inlinable-call exp func dp_func cnt)]

; [(inlinable-call exp func dp_func cnt)
; -->
; (is-define-prim exp func dp_func {maximum inlinable-call exp func dp_func} {prim-count dp_func})]


; ; Combinator
; [(eval exp _ _)
; (= exp (app lam _))
; (= lam (lambda var body))
; (~ store (f-addr _ x) (define-prim x _))
; (free x lam)
;  -->
; (is-combinator exp lam x)]

; GENERATING CALL-SETS FOR FUNCTIONS
[(= e (app ef [eas ...]))
 (apply vf _ _ _ e)
 -->
 (fun-at-call e vf)]

[(fun-at-call e vf)
 (count fun-at-call e _ cnt)
 -->
 (fun-at-call-count e cnt)]

[(free var exp)
 -->
 (freevars exp var)]



; CONTEXT SENSITIVE ABS. COUNTING
[(store (f-addr ctx var) val)
 -->
 (temp-abstract-count (store (f-addr ctx var) val) 1)
 (abstract-count (f-addr ctx var) 1)]

; under the same context if an address is used again, 
; we are bumping up the count to 2
[(temp-abstract-count (store (f-addr ctx var) val1) cnt)
 (store (f-addr ctx var) val2)
 (= cnt 1)
 (=/= val1 val2)
 -->
 (abstract-count (f-addr ctx var) 2)]

; taking the maximum
[(abstract-count addr cnt)
 -->
 (final-abstract-count addr {maximum abstract-count addr})]