Merge pull request #801 from andrew-johnson-4/count-invocations

Count invocations

.gitignore

@@ -30,6 +30,8 @@ benchmarks/*.o
 *.exe
 *.txt
 re-production
+profile
+profile.s
 deploy
 deploy.s
 deploy2.s

Cargo.toml

@@ -1,6 +1,6 @@
 [package]
 name = "lambda_mountain"
-version = "1.16.50"
+version = "1.16.51"
 authors = ["Andrew <andrew@subarctic.org>"]
 license = "MIT"
 description = "Typed Macro Assembler (backed by Coq proofs-of-correctness)"

LIB/default-string.lm

@@ -7,3 +7,5 @@ meta
    (example (print 'hello_s))
 ;
 fragment type String; size String 8; atom suffix String _s;
+
++ := λ(: x String)(: y String). (: (clone-rope(+( (SAtom x) (SAtom y) ))) String); 

Makefile

@@ -1,9 +1,9 @@
 
-work:
-	lm tests/regress/cdecl.lm
-	as tmp.s -o tmp.o
-	ld tmp.o -o tmp
-	./tmp
+profile: install-production
+	lm --profile-invocations SRC/index-index.lm -o profile.s
+	as profile.s -o profile.o
+	ld profile.o -o profile
+	./profile SRC/index-index.lm | sort -n
 
 build-docs:
 	lm --blob -o docs/index.html docs/index.html.lm

SRC/compile-finish.lm

@@ -2,6 +2,7 @@
 compile-finish := λ. (: (
    (let output SNil)
    (set output (SCons( (close output) (close(compile-text-header())) )))
+   (set output (SCons( (close output) (close assemble-profile-onexit) )))
    (set output (SCons( (close output) (close(compile-exit-cleanup())) )))
    (set output (SCons( (close output) (close assemble-text-section) )))
    (if (non-zero assemble-data-section) (

SRC/compile-global.lm

@@ -5,6 +5,7 @@ compile-global := λ(: ctx FContext)(: k String)(: term AST). (: (
    (match term (
       ()
       ( (Abs( lhs rhs tlt )) (if (||( (is-open kt) (non-zero(slot( tlt 'Blob_s ))) )) () (
+
          (let args-type (domain kt))
          (let args-size (sizeof-aligned args-type))
          (set ctx (compile-destructure-args( args-type ctx lhs 0_i64 )))
@@ -28,6 +29,31 @@ compile-global := λ(: ctx FContext)(: k String)(: term AST). (: (
             (set text (SCons( (close text) (close(SAtom( (mangle-identifier( k kt )) ))) )))
          ))
          (set text (SCons( (close text) (close(SAtom( ':\n_s ))) )))
+         (if (==( config-profile-invocations True_u8 )) (
+            (let counter-id (+( (SAtom(mangle-identifier( k kt ))) (SAtom '_COUNTER_s) )))
+            (set assemble-data-section (+( assemble-data-section (+(
+               (+( counter-id (SAtom ':\n.zero\s8\n_s) ))
+               (+(
+                  (+( counter-id (SAtom '_LABEL:\n\t.ascii\t"\\\\t_s) ))
+                  (+( counter-id (SAtom '\\\\n"\n\t.zero\s1\n_s) ))
+               ))
+            )) )))
+            (set text (+( text (+(
+               (+( (SAtom '\tmov\s$_s) (+( counter-id (SAtom ',\s%RBX\n\tmov\s0\[%RBX\],\s%RAX\n_s) )) ))
+               (SAtom '\tinc\s%RAX\n\tmov\s%RAX,\s0\[%RBX\]\n_s)
+            )) )))
+            (set assemble-profile-onexit (+( assemble-profile-onexit (+(
+               (+(
+                  (+( (SAtom '\tmov\s$_s) (+( counter-id (SAtom ',\s%RBX\n\tmov\s0\[%RBX\],\s%RAX\n_s) )) ))
+                  (SAtom '\tpush\s%RBP\n\tmov\s%RSP,\s%RBP\n\tpush\s%RAX\n\tcall\sprint_CL_ArrowNilU64\n\tmov\s%RBP,\s%RSP\n\tpop\s%RBP\n_s)
+               ))
+               (+(
+                  (+( (SAtom '\tpush\s%RBP\n\tmov\s%RSP,\s%RBP\n\tpush\s$_s) (+( counter-id (SAtom '_LABEL\n_s) )) ))
+                  (SAtom '\tcall\sprint_CL_ArrowNilString\n\tmov\s%RBP,\s%RSP\n\tpop\s%RBP\n_s)
+               ))
+            )) )))
+         ) ())
+
          (let frame (fragment::get( e 'frame_s )))
          (set text (SCons( (close text) (close frame) )))
          (let program (fragment::get( e 'program_s )))

SRC/index-globals.lm

@@ -2,12 +2,14 @@
 assemble-text-section                    := (: SNil S);
 assemble-init-section                    := (: SNil S);
 assemble-data-section                    := (: SNil S);
+assemble-profile-onexit                  := (: SNil S);
 assemble-final                           := '_s;
 assemble-argv-referenced                 := False_u8;
 
 main-with-argv := False_u8;
 main-with := False_u8;
 
+config-profile-invocations   := False_u8;
 config-strict                := True_u8;
 config-preprocess            := True_u8;
 config-target                := 'tmp.s_s;

SRC/main.lm

@@ -16,6 +16,7 @@ main := λ(: argc U64)(: argv String[]). (: (
          ('--gradual_s (set config-strict False_u8))
          ('--macro_s (set config-preprocess True_u8))
          ('--nomacro_s (set config-preprocess False_u8))
+         ('--profile-invocations_s (set config-profile-invocations True_u8))
          ('-o_s (
             (set argi (+( argi 1_u64 )))
             (set config-target ([]( argv argi )))