Skip to content

Instantly share code, notes, and snippets.

@eholk

eholk/remove-closures.scm

Created May 5, 2015 19:26
Show Gist options
  • Save eholk/92a65dc28fc0d35dc551 to your computer and use it in GitHub Desktop.
Save eholk/92a65dc28fc0d35dc551 to your computer and use it in GitHub Desktop.
Download ZIP
Weird nanopass behavior
Raw
gistfile1.txt
|(remove-closures
(closures
((lambda-type_802
dispatch_803
(closure lambda_233 (int) -> (adt point3f-t_164))
(lambda_801
(__153)
(let ([x_154 float
(call
(var (fn ((ptr FILE)) -> float) file-read-float)
(var (ptr FILE) file_146))])
(let ([y_155 float
(call
(var (fn ((ptr FILE)) -> float) file-read-float)
(var (ptr FILE) file_146))])
(let ([z_156 float
(call
(var (fn ((ptr FILE)) -> float) file-read-float)
(var (ptr FILE) file_146))])
(let ([confidence_157 float
(call
(var (fn ((ptr FILE)) -> float) file-read-float)
(var (ptr FILE) file_146))])
(let ([intensity_158 float
(call
(var (fn ((ptr FILE)) -> float) file-read-float)
(var (ptr FILE) file_146))])
(call
(var (fn (float float float) -> (adt point3f-t_164))
point3f)
(var float x_154)
(var float y_155)
(var float z_156)))))))
(file_146 (ptr FILE)))))
(module (extern close_outfile ((ptr ofstream)) -> void)
(extern command-line () -> (vec vec_r_168 str))
(extern flush-stdout () -> void)
(extern get-environment-variable (str) -> str)
(extern nanotime () -> u64)
(extern open_outfile (str) -> (ptr ofstream))
(extern str->vec (str) -> (vec vec_r_167 char))
(extern time-s () -> float)
(fn char->int
(c_2)
(fn (char) -> int)
(let-region () (return (cast int (var char c_2)))))
(fn int->float
(i_3)
(fn (int) -> float)
(let-region () (return (cast float (var int i_3)))))
(fn float->int
(f_4)
(fn (float) -> int)
(let-region () (return (cast int (var float f_4)))))
(define-datatype u64-value_166 (u64-value u64))
(fn print
(adt_797 out_798)
(fn ((adt u64-value_166) (ptr ofstream)) -> void)
(begin
(do (match
int
[var (adt u64-value_166) adt_797]
[(u64-value x_799) (begin
(print
(str "(u64-value")
(var (ptr ofstream) out_798))
(begin
(print
(str " ")
(var (ptr ofstream) out_798))
(print
(var u64 x_799)
(var (ptr ofstream) out_798)))
(print
(str ")")
(var (ptr ofstream) out_798))
(int 0))]))
(return)))
(fn print
(adt_797)
(fn ((adt u64-value_166)) -> void)
(begin
(do (match
int
[var (adt u64-value_166) adt_797]
[(u64-value x_800) (begin
(print (str "(u64-value"))
(begin
(print (str " "))
(print (var u64 x_800)))
(print (str ")"))
(int 0))]))
(return)))
(fn u64_max
()
(fn () -> u64)
(let-region
()
(return
(match u64
[call
(var (fn (u64) -> (adt u64-value_166)) u64-value)
(u64 18446744073709551615)]
[(u64-value i_5) (var u64 i_5)]))))
(fn u64->float
(u_6)
(fn (u64) -> float)
(let-region () (return (cast float (var u64 u_6)))))
(fn parse-char-vec->int-helper
(v_10 default_9 i_8 acc_7)
(fn ((vec vec_r_167 char) int int int) -> int)
(let-region
()
(if (= (length (var (vec vec_r_167 char) v_10)) (var int i_8))
(return (var int acc_7))
(let ([c_11 int
(call
(var (fn (char) -> int) char->int)
(vector-ref
char
(var (vec vec_r_167 char) v_10)
(var int i_8)))])
(if (if (<= (call
(var (fn (char) -> int) char->int)
(char #\0))
(var int c_11))
(<= (var int c_11)
(call
(var (fn (char) -> int) char->int)
(char #\9)))
(bool #f))
(return
(call
(var (fn ((vec vec_r_167 char) int int int) -> int)
parse-char-vec->int-helper)
(var (vec vec_r_167 char) v_10) (var int default_9)
(+ (int 1) (var int i_8))
(+ (- (var int c_11)
(call
(var (fn (char) -> int) char->int)
(char #\0)))
(* (int 10) (var int acc_7)))))
(return (var int default_9)))))))
(fn parse-char-vec->int
(v_13 default_12)
(fn ((vec vec_r_167 char) int) -> int)
(let-region
()
(return
(call
(var (fn ((vec vec_r_167 char) int int int) -> int)
parse-char-vec->int-helper)
(var (vec vec_r_167 char) v_13) (var int default_12) (int 0)
(int 0)))))
(fn parse-str->int
(s_15 default_14)
(fn (str int) -> int)
(let-region
(vec_r_167)
(return
(call
(var (fn ((vec vec_r_167 char) int) -> int)
parse-char-vec->int)
(call
(var (fn (str) -> (vec vec_r_167 char)) str->vec)
(var str s_15))
(var int default_14)))))
(fn elapsed-sec
(start_17 end_16)
(fn (u64 u64) -> float)
(let-region
()
(return
(/ (call
(var (fn (u64) -> float) u64->float)
(- (var u64 end_16) (var u64 start_17)))
(float 1000000000.0)))))
(extern unsafe-deref-float ((ptr float) int) -> float)
(extern unsafe-deref-int ((ptr int) int) -> int)
(extern unsafe-deref-char ((ptr char) int) -> char)
(extern unsafe-set!-float ((ptr float) int float) -> void)
(extern unsafe-set!-int ((ptr int) int int) -> void)
(extern unsafe-set!-char ((ptr char) int char) -> void)
(fn import-int-vec
(p_19 n_18)
(fn ((ptr int) int) -> (vec rk_710 int))
(let-region
(r_709)
(let ([v_22 (vec rk_710 int)
(let ([t_20 int (int 0)])
(kernel
(vec rk_710 int)
rk_710
(((i_21 int)
((iota-r r_709 (var int n_18)) (vec r_709 int))))
(var int t_20)))])
(let ([vp_23 (ptr int)
(unsafe-vec-ptr (ptr int) (var (vec rk_710 int) v_22))])
(begin
(let ([i_26 int (int 0)]
[stepv_25 int (int 1)]
[stopv_24 int (var int n_18)])
(while
(< (var int i_26) (var int stopv_24))
(begin
(do (call
[var (fn ((ptr int) int int) -> void) unsafe-set!-int]
[var (ptr int) vp_23]
[var int i_26]
[call (var (fn ((ptr int) int) -> int)
unsafe-deref-int) (var (ptr int) p_19) (var int
i_26)]))
(set! (var int i_26)
(+ (var int i_26) (var int stepv_25))))))
(return (var (vec rk_710 int) v_22)))))))
(fn import-float-vec
(p_28 n_27)
(fn ((ptr float) int) -> (vec rk_690 float))
(let-region
(r_689)
(let ([v_31 (vec rk_690 float)
(let ([t_29 float (int 0)])
(kernel
(vec rk_690 float)
rk_690
(((i_30 int)
((iota-r r_689 (var int n_27)) (vec r_689 int))))
(var float t_29)))])
(let ([vp_32 (ptr float)
(unsafe-vec-ptr
(ptr float)
(var (vec rk_690 float) v_31))])
(begin
(let ([i_35 int (int 0)]
[stepv_34 int (int 1)]
[stopv_33 int (var int n_27)])
(while
(< (var int i_35) (var int stopv_33))
(begin
(do (call
[var (fn ((ptr float) int float) -> void) unsafe-set!-float]
[var (ptr float) vp_32]
[var int i_35]
[call (var (fn ((ptr float) int) -> float)
unsafe-deref-float) (var (ptr float)
p_28) (var int
i_35)]))
(set! (var int i_35)
(+ (var int i_35) (var int stepv_34))))))
(return (var (vec rk_690 float) v_31)))))))
(extern fopen (str str) -> (ptr FILE))
(extern fclose ((ptr FILE)) -> int)
(extern fread ((ptr void) size_t size_t (ptr FILE)) -> size_t)
(extern hscanf ((ptr FILE) str (ptr int)) -> int)
(extern hscanf-float ((ptr FILE) str (ptr float)) -> int)
(extern hscanfu64 ((ptr FILE) (ptr u64)) -> int)
(extern hgets ((ptr FILE)) -> str)
(extern file-read-line ((ptr FILE)) -> str)
(fn file-open
(name_36)
(fn (str) -> (ptr FILE))
(let-region
()
(return
(call
(var (fn (str str) -> (ptr FILE)) fopen)
(var str name_36)
(str "r")))))
(fn file-close
(f_37)
(fn ((ptr FILE)) -> bool)
(let-region
()
(begin
(do (call
[var (fn ((ptr FILE)) -> int) fclose]
[var (ptr FILE) f_37]))
(return (bool #f)))))
(fn read-binary-float
(f_38)
(fn ((ptr FILE)) -> float)
(let-region
(rv_663)
(let ([tmp_39 (vec rv_663 float)
(vector (vec rv_663 float) rv_663 (float 0.0))])
(begin
(do (call
[var (fn ((ptr void) size_t size_t (ptr FILE)) -> size_t) fread]
[cast (ptr void) (unsafe-vec-ptr
(ptr float)
(var (vec rv_663 float) tmp_39))]
[cast size_t (int 4)]
[cast size_t (int 1)]
[var (ptr FILE) f_38]))
(return
(vector-ref
float
(var (vec rv_663 float) tmp_39)
(int 0)))))))
(fn read-binary-u32
(f_40)
(fn ((ptr FILE)) -> int)
(let-region
(rv_644)
(let ([tmp_41 (vec rv_644 int)
(vector (vec rv_644 int) rv_644 (int 0))])
(begin
(do (call
[var (fn ((ptr void) size_t size_t (ptr FILE)) -> size_t) fread]
[cast (ptr void) (unsafe-vec-ptr
(ptr int)
(var (vec rv_644 int) tmp_41))]
[cast size_t (int 4)]
[cast size_t (int 1)]
[var (ptr FILE) f_40]))
(return
(vector-ref int (var (vec rv_644 int) tmp_41) (int 0)))))))
(fn read-binary-u16
(f_42)
(fn ((ptr FILE)) -> int)
(let-region
(rv_625)
(let ([tmp_43 (vec rv_625 int)
(vector (vec rv_625 int) rv_625 (int 0))])
(begin
(do (call
[var (fn ((ptr void) size_t size_t (ptr FILE)) -> size_t) fread]
[cast (ptr void) (unsafe-vec-ptr
(ptr int)
(var (vec rv_625 int) tmp_43))]
[cast size_t (int 2)]
[cast size_t (int 1)]
[var (ptr FILE) f_42]))
(return
(vector-ref int (var (vec rv_625 int) tmp_43) (int 0)))))))
(fn read-binary-char
(f_44)
(fn ((ptr FILE)) -> char)
(let-region
(rv_606)
(let ([tmp_45 (vec rv_606 char)
(vector (vec rv_606 char) rv_606 (int 0))])
(begin
(do (call
[var (fn ((ptr void) size_t size_t (ptr FILE)) -> size_t) fread]
[cast (ptr void) (unsafe-vec-ptr
(ptr char)
(var (vec rv_606 char) tmp_45))]
[cast size_t (int 1)]
[cast size_t (int 1)]
[var (ptr FILE) f_44]))
(return
(vector-ref char (var (vec rv_606 char) tmp_45) (int 0)))))))
(fn file-read-int
(f_46)
(fn ((ptr FILE)) -> int)
(let-region
(rv_592)
(let ([tmp_47 (vec rv_592 int)
(vector (vec rv_592 int) rv_592 (int 0))])
(begin
(do (call
[var (fn ((ptr FILE) str (ptr int)) -> int) hscanf]
[var (ptr FILE) f_46]
[str "%d"]
[unsafe-vec-ptr (ptr int) (var (vec rv_592 int) tmp_47)]))
(return
(vector-ref int (var (vec rv_592 int) tmp_47) (int 0)))))))
(fn file-read-float
(f_48)
(fn ((ptr FILE)) -> float)
(let-region
(rv_578)
(let ([tmp_49 (vec rv_578 float)
(vector (vec rv_578 float) rv_578 (int 0))])
(begin
(do (call
[var (fn ((ptr FILE) str (ptr float)) -> int) hscanf-float]
[var (ptr FILE) f_48]
[str "%f"]
[unsafe-vec-ptr (ptr float) (var (vec rv_578 float)
tmp_49)]))
(return
(vector-ref
float
(var (vec rv_578 float) tmp_49)
(int 0)))))))
(fn file-read-string
(f_50)
(fn ((ptr FILE)) -> str)
(let-region
()
(return
(call
(var (fn ((ptr FILE)) -> str) hgets)
(var (ptr FILE) f_50)))))
(fn file-read-u64
(f_51)
(fn ((ptr FILE)) -> u64)
(let-region
(rv_562)
(let ([tmp_52 (vec rv_562 u64)
(vector (vec rv_562 u64) rv_562 (int 0))])
(begin
(do (call
[var (fn ((ptr FILE) (ptr u64)) -> int) hscanfu64]
[var (ptr FILE) f_51]
[unsafe-vec-ptr (ptr u64) (var (vec rv_562 u64) tmp_52)]))
(return
(vector-ref u64 (var (vec rv_562 u64) tmp_52) (int 0)))))))
(define-datatype point3i-t_165 (point3i int int int))
(fn print
(adt_789 out_790)
(fn ((adt point3i-t_165) (ptr ofstream)) -> void)
(begin
(do (match
int
[var (adt point3i-t_165) adt_789]
[(point3i x_793 x_792 x_791) (begin
(print
(str "(point3i")
(var (ptr ofstream) out_790))
(begin
(print
(str " ")
(var (ptr ofstream)
out_790))
(print
(var int x_793)
(var (ptr ofstream)
out_790)))
(begin
(print
(str " ")
(var (ptr ofstream)
out_790))
(print
(var int x_792)
(var (ptr ofstream)
out_790)))
(begin
(print
(str " ")
(var (ptr ofstream)
out_790))
(print
(var int x_791)
(var (ptr ofstream)
out_790)))
(print
(str ")")
(var (ptr ofstream) out_790))
(int 0))]))
(return)))
(fn print
(adt_789)
(fn ((adt point3i-t_165)) -> void)
(begin
(do (match
int
[var (adt point3i-t_165) adt_789]
[(point3i x_796 x_795 x_794) (begin
(print (str "(point3i"))
(begin
(print (str " "))
(print (var int x_796)))
(begin
(print (str " "))
(print (var int x_795)))
(begin
(print (str " "))
(print (var int x_794)))
(print (str ")"))
(int 0))]))
(return)))
(define-datatype point3f-t_164 (point3f float float float))
(fn print
(adt_781 out_782)
(fn ((adt point3f-t_164) (ptr ofstream)) -> void)
(begin
(do (match
int
[var (adt point3f-t_164) adt_781]
[(point3f x_785 x_784 x_783) (begin
(print
(str "(point3f")
(var (ptr ofstream) out_782))
(begin
(print
(str " ")
(var (ptr ofstream)
out_782))
(print
(var float x_785)
(var (ptr ofstream)
out_782)))
(begin
(print
(str " ")
(var (ptr ofstream)
out_782))
(print
(var float x_784)
(var (ptr ofstream)
out_782)))
(begin
(print
(str " ")
(var (ptr ofstream)
out_782))
(print
(var float x_783)
(var (ptr ofstream)
out_782)))
(print
(str ")")
(var (ptr ofstream) out_782))
(int 0))]))
(return)))
(fn print
(adt_781)
(fn ((adt point3f-t_164)) -> void)
(begin
(do (match
int
[var (adt point3f-t_164) adt_781]
[(point3f x_788 x_787 x_786) (begin
(print (str "(point3f"))
(begin
(print (str " "))
(print (var float x_788)))
(begin
(print (str " "))
(print (var float x_787)))
(begin
(print (str " "))
(print (var float x_786)))
(print (str ")"))
(int 0))]))
(return)))
(fn clamp
(i_53)
(fn (int) -> int)
(let-region
()
(if (< (var int i_53) (int 0))
(return (int 0))
(if (> (var int i_53) (int 255))
(return (int 255))
(return (var int i_53))))))
(fn hsv->rgb
(h_56 s_55 v_54)
(fn (float float float) -> (adt point3i-t_165))
(let-region
()
(let ([h_57 float (/ (var float h_56) (int 60))])
(let ([i_58 float
(call
(var (fn (float) -> float) floor)
(var float h_57))])
(let ([f_59 float (- (var float h_57) (var float i_58))])
(let ([p_60 float
(* (var float v_54) (- (int 1) (var float s_55)))])
(let ([q_61 float
(* (var float v_54)
(- (int 1)
(* (var float s_55) (var float f_59))))])
(let ([t_62 float
(* (var float v_54)
(- (int 1)
(* (var float s_55)
(- (int 1) (var float f_59)))))])
(let ([v_66 int
(call
(var (fn (float) -> int) float->int)
(* (int 256) (var float v_54)))]
[t_65 int
(call
(var (fn (float) -> int) float->int)
(* (int 256) (var float t_62)))]
[q_64 int
(call
(var (fn (float) -> int) float->int)
(* (int 256) (var float q_61)))]
[p_63 int
(call
(var (fn (float) -> int) float->int)
(* (int 256) (var float p_60)))])
(if (< (var float i_58) (int 1))
(return
(call
(var (fn (int int int)
->
(adt point3i-t_165))
point3i)
(var int v_66)
(var int t_65)
(var int p_63)))
(if (< (var float i_58) (int 2))
(return
(call
(var (fn (int int int)
->
(adt point3i-t_165))
point3i)
(var int q_64)
(var int v_66)
(var int p_63)))
(if (< (var float i_58) (int 3))
(return
(call
(var (fn (int int int)
->
(adt point3i-t_165))
point3i)
(var int p_63)
(var int v_66)
(var int t_65)))
(if (< (var float i_58) (int 4))
(return
(call
(var (fn (int int int)
->
(adt point3i-t_165))
point3i)
(var int p_63)
(var int q_64)
(var int v_66)))
(if (< (var float i_58) (int 5))
(return
(call
(var (fn (int int int)
->
(adt point3i-t_165))
point3i)
(var int t_65)
(var int p_63)
(var int v_66)))
(return
(call
(var (fn (int int int)
->
(adt point3i-t_165))
point3i)
(var int v_66)
(var int p_63)
(var int
q_64)))))))))))))))))
(fn write-ppm
(file_68 data_67)
(fn (str (vec rvref_429 (vec rvl_426 (adt point3i-t_165)))) -> void)
(let-region
()
(let ([stream_71 (ptr ofstream)
(call
(var (fn (str) -> (ptr ofstream)) open_outfile)
(var str file_68))]
[rows_70 int
(length
(var (vec rvref_429 (vec rvl_426 (adt point3i-t_165)))
data_67))]
[cols_69 int
(length
(vector-ref
(vec rvl_426 (adt point3i-t_165))
(var (vec rvref_429 (vec rvl_426 (adt point3i-t_165)))
data_67)
(int 0)))])
(begin
(let ([stream_72 (ptr ofstream)
(var (ptr ofstream) stream_71)])
(begin
(print (str "P3") (var (ptr ofstream) stream_71))
(print (str "\n") (var (ptr ofstream) stream_71))))
(print (var int rows_70) (var (ptr ofstream) stream_71))
(print (str " ") (var (ptr ofstream) stream_71))
(let ([stream_73 (ptr ofstream)
(var (ptr ofstream) stream_71)])
(begin
(print (var int cols_69) (var (ptr ofstream) stream_71))
(print (str "\n") (var (ptr ofstream) stream_71))))
(let ([stream_74 (ptr ofstream)
(var (ptr ofstream) stream_71)])
(begin
(print (str "255") (var (ptr ofstream) stream_71))
(print (str "\n") (var (ptr ofstream) stream_71))))
(let ([i_77 int (int 0)]
[stepv_76 int (int 1)]
[stopv_75 int (var int rows_70)])
(while
(< (var int i_77) (var int stopv_75))
(begin
(let ([j_80 int (int 0)]
[stepv_79 int (int 1)]
[stopv_78 int (var int cols_69)])
(while
(< (var int j_80) (var int stopv_78))
(begin
(let ([p_81 (adt point3i-t_165)
(vector-ref
(adt point3i-t_165)
(vector-ref
(vec rvl_426 (adt point3i-t_165))
(var (vec rvref_429
(vec rvl_426
(adt point3i-t_165)))
data_67)
(var int i_77))
(var int j_80))])
(begin
(do (match
int
[var (adt point3i-t_165) p_81]
[(point3i r_84 g_83 b_82) (begin
(print
(call
(var (fn (int)
->
int)
clamp)
(var int
r_84))
(var (ptr ofstream)
stream_71))
(print
(str " ")
(var (ptr ofstream)
stream_71))
(print
(call
(var (fn (int)
->
int)
clamp)
(var int
g_83))
(var (ptr ofstream)
stream_71))
(print
(str " ")
(var (ptr ofstream)
stream_71))
(print
(call
(var (fn (int)
->
int)
clamp)
(var int
b_82))
(var (ptr ofstream)
stream_71))
(int 42))]))
(print
(str " ")
(var (ptr ofstream) stream_71))))
(set! (var int j_80)
(+ (var int j_80) (var int stepv_79))))))
(print (str "\n") (var (ptr ofstream) stream_71))
(set! (var int i_77)
(+ (var int i_77) (var int stepv_76))))))
(return
(call
(var (fn ((ptr ofstream)) -> void) close_outfile)
(var (ptr ofstream) stream_71)))))))
(fn write-pgm
(file_86 data_85)
(fn (str (vec rvref_376 (vec rvl_373 int))) -> void)
(let-region
()
(let ([stream_89 (ptr ofstream)
(call
(var (fn (str) -> (ptr ofstream)) open_outfile)
(var str file_86))]
[rows_88 int
(length (var (vec rvref_376 (vec rvl_373 int)) data_85))]
[cols_87 int
(length
(vector-ref
(vec rvl_373 int)
(var (vec rvref_376 (vec rvl_373 int)) data_85)
(int 0)))])
(begin
(print (str "P2\n") (var (ptr ofstream) stream_89))
(print (var int rows_88) (var (ptr ofstream) stream_89))
(print (str " ") (var (ptr ofstream) stream_89))
(print (var int cols_87) (var (ptr ofstream) stream_89))
(print (str "\n") (var (ptr ofstream) stream_89))
(print (str "255\n") (var (ptr ofstream) stream_89))
(let ([i_92 int (int 0)]
[stepv_91 int (int 1)]
[stopv_90 int (var int rows_88)])
(while
(< (var int i_92) (var int stopv_90))
(begin
(let ([j_95 int (int 0)]
[stepv_94 int (int 1)]
[stopv_93 int (var int cols_87)])
(while
(< (var int j_95) (var int stopv_93))
(begin
(let ([p_96 int
(vector-ref
int
(vector-ref
(vec rvl_373 int)
(var (vec rvref_376 (vec rvl_373 int))
data_85)
(var int i_92))
(var int j_95))])
(begin
(print
(if (< (var int p_96) (int 0))
(begin (int 0))
(if (> (var int p_96) (int 255))
(begin (int 255))
(begin (var int p_96))))
(var (ptr ofstream) stream_89))
(print
(str " ")
(var (ptr ofstream) stream_89))))
(set! (var int j_95)
(+ (var int j_95) (var int stepv_94))))))
(set! (var int i_92)
(+ (var int i_92) (var int stepv_91))))))
(return
(call
(var (fn ((ptr ofstream)) -> void) close_outfile)
(var (ptr ofstream) stream_89)))))))
(fn point-diff
(x_98 y_97)
(fn ((adt point3f-t_164) (adt point3f-t_164)) -> (adt point3f-t_164))
(let-region
()
(return
(match (adt point3f-t_164)
[var (adt point3f-t_164) x_98]
[(point3f a_101 b_100 c_99)
(match (adt point3f-t_164)
[var (adt point3f-t_164) y_97]
[(point3f d_104 e_103 f_102)
(call
(var (fn (float float float) -> (adt point3f-t_164))
point3f)
(- (var float a_101) (var float d_104))
(- (var float b_100) (var float e_103))
(- (var float c_99) (var float f_102)))])]))))
(fn point-add
(x_106 y_105)
(fn ((adt point3f-t_164) (adt point3f-t_164)) -> (adt point3f-t_164))
(let-region
()
(return
(match (adt point3f-t_164)
[var (adt point3f-t_164) x_106]
[(point3f a_109 b_108 c_107)
(match (adt point3f-t_164)
[var (adt point3f-t_164) y_105]
[(point3f x_112 y_111 z_110)
(call
(var (fn (float float float) -> (adt point3f-t_164))
point3f)
(+ (var float a_109) (var float x_112))
(+ (var float b_108) (var float y_111))
(+ (var float c_107) (var float z_110)))])]))))
(fn point-div
(match-tmp_114 y_113)
(fn ((adt point3f-t_164) float) -> (adt point3f-t_164))
(let-region
()
(return
(match (adt point3f-t_164)
[var (adt point3f-t_164) match-tmp_114]
[(point3f a_117 b_116 c_115)
(call
(var (fn (float float float) -> (adt point3f-t_164))
point3f)
(/ (var float a_117) (var float y_113))
(/ (var float b_116) (var float y_113))
(/ (var float c_115) (var float y_113)))]))))
(fn point-scale
(match-tmp_119 y_118)
(fn ((adt point3f-t_164) float) -> (adt point3f-t_164))
(let-region
()
(return
(match (adt point3f-t_164)
[var (adt point3f-t_164) match-tmp_119]
[(point3f a_122 b_121 c_120)
(call
(var (fn (float float float) -> (adt point3f-t_164))
point3f)
(* (var float a_122) (var float y_118))
(* (var float b_121) (var float y_118))
(* (var float c_120) (var float y_118)))]))))
(fn dot-prod
(a_124 b_123)
(fn ((adt point3f-t_164) (adt point3f-t_164)) -> float)
(let-region
()
(return
(match float
[var (adt point3f-t_164) a_124]
[(point3f ax_127 ay_126 az_125)
(match float
[var (adt point3f-t_164) b_123]
[(point3f bx_130 by_129 bz_128)
(+ (* (var float ax_127) (var float bx_130))
(+ (* (var float ay_126) (var float by_129))
(* (var float az_125) (var float bz_128))))])]))))
(fn point-mag
(p_131)
(fn ((adt point3f-t_164)) -> float)
(let-region
()
(return
(call
(var (fn (float) -> float) harlan_sqrt)
(call
(var (fn ((adt point3f-t_164) (adt point3f-t_164)) -> float)
dot-prod)
(var (adt point3f-t_164) p_131)
(var (adt point3f-t_164) p_131))))))
(fn unit-length
(p_132)
(fn ((adt point3f-t_164)) -> (adt point3f-t_164))
(let-region
()
(return
(call
(var (fn ((adt point3f-t_164) float) -> (adt point3f-t_164))
point-div)
(var (adt point3f-t_164) p_132)
(call
(var (fn ((adt point3f-t_164)) -> float) point-mag)
(var (adt point3f-t_164) p_132))))))
(fn rgbf->rgbi
(x_133)
(fn ((adt point3f-t_164)) -> (adt point3i-t_165))
(let-region
()
(return
(match (adt point3i-t_165)
[var (adt point3f-t_164) x_133]
[(point3f r_136 g_135 b_134)
(call
(var (fn (int int int) -> (adt point3i-t_165)) point3i)
(call
(var (fn (float) -> int) float->int)
(* (var float r_136) (int 256)))
(call
(var (fn (float) -> int) float->int)
(* (var float g_135) (int 256)))
(call
(var (fn (float) -> int) float->int)
(* (var float b_134) (int 256))))]))))
(fn process-header
(file_139 vertices_138 faces_137)
(fn ((ptr FILE) int int) -> int)
(let-region
()
(begin
(print (str "."))
(let ([word_140 str
(call
(var (fn ((ptr FILE)) -> str) file-read-string)
(var (ptr FILE) file_139))])
(if (= (var str word_140) (str "end_header"))
(begin
(print (str ""))
(print (str "\n"))
(return
(call
(var (fn ((ptr FILE) int int) -> int)
read-vertex-data)
(var (ptr FILE) file_139)
(var int vertices_138)
(var int faces_137))))
(if (= (var str word_140) (str "format"))
(begin
(assert
(= (call
(var (fn ((ptr FILE)) -> str)
file-read-string)
(var (ptr FILE) file_139))
(str "ascii")))
(assert
(= (call
(var (fn ((ptr FILE)) -> str)
file-read-string)
(var (ptr FILE) file_139))
(str "1.0")))
(return
(call
(var (fn ((ptr FILE) int int) -> int)
process-header)
(var (ptr FILE) file_139)
(var int vertices_138)
(var int faces_137))))
(if (= (var str word_140) (str "comment"))
(begin
(do (call
[var (fn ((ptr FILE)) -> str) file-read-line]
[var (ptr FILE) file_139]))
(return
(call
(var (fn ((ptr FILE) int int) -> int)
process-header)
(var (ptr FILE) file_139)
(var int vertices_138)
(var int faces_137))))
(if (= (var str word_140) (str "element"))
(let ([kind_141 str
(call
(var (fn ((ptr FILE)) -> str)
file-read-string)
(var (ptr FILE) file_139))])
(if (= (var str kind_141) (str "vertex"))
(let ([vertices_142 int
(call
(var (fn ((ptr FILE)) -> int)
file-read-int)
(var (ptr FILE) file_139))])
(begin
(print (str "\n"))
(print (var int vertices_142))
(print (str " vertices"))
(print (str "\n"))
(return
(call
(var (fn ((ptr FILE) int int)
->
int)
process-header)
(var (ptr FILE) file_139)
(var int vertices_142)
(var int faces_137)))))
(if (= (var str kind_141) (str "face"))
(let ([faces_143 int
(call
(var (fn ((ptr FILE))
->
int)
file-read-int)
(var (ptr FILE)
file_139))])
(begin
(print (str "\n"))
(print (var int faces_143))
(print (str " faces"))
(print (str "\n"))
(return
(call
(var (fn ((ptr FILE) int int)
->
int)
process-header)
(var (ptr FILE) file_139)
(var int vertices_138)
(var int faces_143)))))
(do (call
[var (fn () -> void) harlan_error]
[str "Uknown element type"])))))
(return
(call
(var (fn ((ptr FILE) int int) -> int)
process-header)
(var (ptr FILE) file_139)
(var int vertices_138)
(var int faces_137)))))))))))
(fn read-vertex-data
(file_146 vertices_145 faces_144)
(fn ((ptr FILE) int int) -> int)
(let-region
(r_215 lambda_233 rk_216)
(let ([vertices_159 (vec rk_216 (adt point3f-t_164))
(let ([v_149 (vec rk_216 (adt point3f-t_164))
(let ([t_147 (adt point3f-t_164)
(call
(var (fn (float float float)
->
(adt point3f-t_164))
point3f)
(int 0)
(int 0)
(int 0))])
(kernel
(vec rk_216 (adt point3f-t_164))
rk_216
(((i_148 int)
((iota-r r_215 (var int vertices_145))
(vec r_215 int))))
(var (adt point3f-t_164) t_147)))])
(begin
(let ([i_152 int (int 0)]
[stepv_151 int (int 1)]
[stopv_150 int
(length
(var (vec rk_216 (adt point3f-t_164))
v_149))])
(while
(< (var int i_152) (var int stopv_150))
(begin
(set! (vector-ref
(adt point3f-t_164)
(var (vec rk_216 (adt point3f-t_164))
v_149)
(var int i_152))
(invoke
(make-closure
(closure
lambda_233
(int)
->
(adt point3f-t_164))
lambda_801
(var (ptr FILE) file_146))
(var int i_152)))
(set! (var int i_152)
(+ (var int i_152) (var int stepv_151))))))
(var (vec rk_216 (adt point3f-t_164)) v_149)))])
(begin
(let ([v_778 (vec rk_216 (adt point3f-t_164))
(var (vec rk_216 (adt point3f-t_164)) vertices_159)])
(begin
(print (str "["))
(let ([i_779 int (int 0)]
[len_780 int
(length
(var (vec rk_216 (adt point3f-t_164)) v_778))])
(while
(< (var int i_779) (var int len_780))
(begin
(if (> (var int i_779) (int 0)) (print (str " \n ")))
(print
(vector-ref
(adt point3f-t_164)
(var (vec rk_216 (adt point3f-t_164)) v_778)
(var int i_779)))
(set! (var int i_779) (+ (var int i_779) (int 1))))))
(print (str "]"))))
(print (str "\n"))
(return (int 42))))))
(fn check-header
(file_160)
(fn ((ptr FILE)) -> int)
(let-region
()
(if (= (call
(var (fn ((ptr FILE)) -> str) file-read-string)
(var (ptr FILE) file_160))
(str "ply"))
(return
(call
(var (fn ((ptr FILE) int int) -> int) process-header)
(var (ptr FILE) file_160)
(int 0)
(int 0)))
(do (call
[var (fn () -> void) harlan_error]
[str "Incorrect PLY header"])))))
(fn load-ply
(filename_161)
(fn (str) -> int)
(let-region
()
(let ([file_162 (ptr FILE)
(call
(var (fn (str) -> (ptr FILE)) file-open)
(var str filename_161))])
(return
(call
(var (fn ((ptr FILE)) -> int) check-header)
(var (ptr FILE) file_162))))))
(fn harlan_main
()
(fn () -> int)
(let-region
(vec_r_168)
(let ([args_163 (vec vec_r_168 str)
(call (var (fn () -> (vec vec_r_168 str)) command-line))])
(if (< (length (var (vec vec_r_168 str) args_163)) (int 2))
(begin
(print (str "Filename required as command line argument"))
(print (str "\n"))
(return (int 0)))
(begin
(print (str "Loading "))
(print
(vector-ref
str
(var (vec vec_r_168 str) args_163)
(int 1)))
(print (str "\n"))
(do (call
[var (fn (str) -> int) load-ply]
[vector-ref str (var (vec vec_r_168 str) args_163) (int 1)]))
(return (int 0))))))))))
Exception in Expr: unknown invoke target with irritants ((make-closure (closure lambda_233 (...) -> (...)) lambda_801 (var (...) file_146)) (var (ptr FILE) file_146))
Raw
remove-closures.scm
(trace-define-pass remove-closures : M2 (m) -> M3 ()
(definitions
;; Returns whether types are equivalent up to renaming of region
;; variables.
;;
;; This is the sort of thing where nanopass polymorphism would
;; help.
(define (type-compat? a b)
(let loop ((a a)
(b b)
(env '()))
(nanopass-case2
(M2 Rho-Type) (a b)
(((closure ,r1 (,t1* ...) ,-> ,t1)
(closure ,r2 (,t2* ...) ,-> ,t2))
;; TODO: This needs to consider region variables and
;; renaming.
(and (eq? (length t1*) (length t2*))
(andmap type-compat? (cons t1 t1*) (cons t2 t2*))))
(((ptr ,t1) (ptr ,t2))
(loop t1 t2 env))
(((adt ,x1 ,r1) (adt ,x2 ,r2))
(eq? x1 x2))
(((adt ,x1) (adt ,x2))
(eq? x1 x2))
((,bt1 ,bt2) (equal? bt1 bt2))
(else (begin
;;(pretty-print "Failed Match!")
;;(pretty-print (unparse-M2 a))
;;(pretty-print (unparse-M2 b))
#f)))))
(define (type-of e)
(nanopass-case
(M3 Expr) e
((var ,t ,x) t)
(else (error 'type-of "unimplemented expr" (unparse-M3 e)))))
(define (find-env t env)
(pair-case
env
((c . rest)
(match c
((,x0 ,x1 ,t^)
(if (type-compat? t t^)
`(,x0 ,x1 ,t^)
(find-env t rest)))
(,_ (error 'find-env "Wat?" _))))
(_ => #f)))
(define (find-typename t env)
(match (find-env t env)
((,x0 ,x1 ,t)
x0)
(,_ (begin
(pretty-print (unparse-M2 t))
(pretty-print env)
(error 'find-typename "Wat?" _)))))
(define (find-dispatch t env)
(match (find-env t env)
((,x0 ,x1 ,t)
x1)
(,_ (error 'find-dispatch "Wat?" _)))))
(Rho-Type
: Rho-Type (t env) -> Rho-Type ()
((closure ,r
(,[Rho-Type : t* env -> t*] ...) ,-> ,[Rho-Type : t^ env -> t^])
(let ((adt-name (find-typename t env)))
`(adt ,adt-name ,r))))
(AdtDeclPattern : AdtDeclPattern (pt env) -> AdtDeclPattern ())
(ClosureCase
: ClosureTag (t env) -> AdtDeclPattern ()
((,x (,x0 ...) ,e (,x* ,[Rho-Type : t* env -> t*]) ...)
`(,x ,t* ...)))
(ClosureMatch
: ClosureTag (t formals ftypes env) -> MatchArm ()
((,x (,x0 ...) ,[Expr : e env -> e] (,x1 ,t1) ...)
`((,x ,x1 ...)
(let ((,x0 ,ftypes (var ,ftypes ,formals)) ...)
,e))))
(MakeEnv
: ClosureGroup (cgroup) -> * ()
((,x0 ,x1 ,t ,ctag ...)
`(,x0 ,x1 ,t)))
(ClosureGroup
: ClosureGroup (cgroup env) -> * (typedef dispatch)
((,x0 ,x1 ,t ,ctag ...)
(nanopass-case
(M2 Rho-Type) t
((closure ,r (,t* ...) ,-> ,t)
(values
(with-output-language
(M3 Decl)
`(define-datatype (,x0 ,r) ,(map (lambda (t)
(ClosureCase t env))
ctag) ...))
(with-output-language
(M3 Decl)
(let* ((formals (map (lambda _ (gensym 'formal)) t*))
(t* (map (lambda (t) (Rho-Type t env)) t*))
(t (Rho-Type t env))
(x (gensym 'closure))
(ctype (with-output-language
(M3 Rho-Type)
`(adt ,x0 ,r)))
(arms (map (lambda (t)
(ClosureMatch t formals t* env))
ctag)))
`(fn ,x1 (,(cons x formals) ...)
(fn (,(cons ctype t*) ...) -> ,t)
(return (match ,t (var ,ctype ,x)
,arms ...))))))))
))
(Closures
: Closures (x) -> Module ()
((closures (,cgroup ...) ,m)
(let ((env (map MakeEnv cgroup)))
(let-values (([types dispatches]
(if (null? cgroup)
(values '() '())
(map-values (lambda (g)
(ClosureGroup g env))
cgroup ))))
(Module m env types dispatches)))))
(Body : Body (b env) -> Body ())
(LetBinding : LetBinding (lbind env) -> LetBinding ())
(MatchArm : MatchArm (arm env) -> MatchArm ())
(Decl : Decl (d env) -> Decl ())
(Expr
: Expr (e env) -> Expr ()
((make-closure ,t ,x ,[Expr : e* env -> e*] ...)
(let ((adt-name (find-typename t env)))
(nanopass-case
(M2 Rho-Type) t
((closure ,r (,t* ...) ,-> ,t^)
`(call (var (fn (,(map type-of e*) ...) -> (adt ,adt-name ,r)) ,x)
,e* ...)))))
((invoke ,e ,[Expr : e* env -> e*] ...)
(define e0 e)
(nanopass-case
(M2 Expr) e
((var (closure ,r (,t* ...) ,-> ,t^) ,x)
(let ((e (Expr e env))
(t (with-output-language
(M2 Rho-Type)
`(closure ,r (,t* ...) ,-> ,t^))))
(let ((dispatch (find-dispatch t env))
(t (Rho-Type t env))
(t^ (Rho-Type t^ env))
(t* (map (lambda (t) (Rho-Type t env)) t*)))
`(call
(var (fn (,(cons t t*) ...) -> ,t^)
,dispatch)
,(cons e e*) ...))))
((make-closure (closure ,r (,t* ...) ,-> ,t^) ,x ,[e**] ...)
(let ((e (Expr e env))
(t (with-output-language
(M2 Rho-Type)
`(closure ,r (,t* ...) ,-> ,t^))))
(let ((dispatch (find-dispatch t env))
(t (Rho-Type t env))
(t^ (Rho-Type t^ env))
(t* (map (lambda (t) (Rho-Type t env)) t*)))
`(call
(var (fn (,(cons t t*) ...) -> ,t^)
,dispatch)
,(cons e e*) ...))))
((call (var (fn (,t*^ ...) ,->^ (closure ,r (,t* ...) ,-> ,t^)) ,x)
,e** ...)
(let ((e (Expr e env))
(t (with-output-language
(M2 Rho-Type)
`(closure ,r (,t* ...) ,-> ,t^))))
(let ((dispatch (find-dispatch t env))
(t (Rho-Type t env))
(t^ (Rho-Type t^ env))
(t* (map (lambda (t) (Rho-Type t env)) t*)))
`(call
(var (fn (,(cons t t*) ...) -> ,t^)
,dispatch)
,(cons e e*) ...))))
((match (closure ,r (,t* ...) ,-> ,t^) ,e^ ,arm ...)
(let ((e (Expr e env))
(t (with-output-language
(M2 Rho-Type)
`(closure ,r (,t* ...) ,-> ,t^))))
(let ((dispatch (find-dispatch t env))
(t (Rho-Type t env))
(t^ (Rho-Type t^ env))
(t* (map (lambda (t) (Rho-Type t env)) t*)))
`(call
(var (fn (,(cons t t*) ...) -> ,t^)
,dispatch)
,(cons e e*) ...))))
(else (error 'Expr "unknown invoke target" (unparse-M2 e0) (unparse-M2 e))))))
(Module
: Module (m env types dispatches) -> Module ()
((module ,[decl env -> decl] ...)
`(module ,(append decl types dispatches) ...))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment