Changeset 22522 for misc

Timestamp:

10/07/08 05:27:30 (3 months ago)

Author:

putter

Message:

[elfish/on_sbcl] elfcl runs fib.

Location:

misc/elfish/on_sbcl

Files:

• Elf_SBCL.pm (modified) (1 diff)
• EmitSBCL.pm (modified) (13 diffs)
• Makefile (modified) (2 diffs)
• PrimitivesSBCL.pm (modified) (2 diffs)
• README (modified) (2 diffs)

misc/elfish/on_sbcl/Elf_SBCL.pm

@@ -1 @@
-use Prelude;
+use PrimitivesSBCL;
+use EmitSBCL;
+
 use Match;
 use IRx1_Nodes;
 use IRx1_FromAST;
 use IRx1_Analysis;
-use EmitSimpleP5;
-use PrimitivesP5;
 use Parser;
 use Compiler;
-
-use EmitSBCL;
-#use PrimitivesSBCL; #XXX tmp hack because elf_g can't add files after CommandLine.
-
 use CommandLine;
+elf_main();

misc/elfish/on_sbcl/EmitSBCL.pm

@@ -255 +255 @@
 
 ;;
+(defun flatten-lists (args)
+  (reduce #\'append
+          (mapcar (lambda (e) (if (and (listp e) (not (null e)))
+                                  e (list e)))
+                  args)))
+
+;;
 (dm |M::new| ((co |Any/cls|) &rest argl)
   (declare (ignorable argl))
@@ -271 +278 @@
  ;;Array.new is defined here to a avoid cyclic dependency on *@args.
 (pkg-declare "class" "Array" \'|Any/cls|)
-(eval \'(dm |M::new| ((co |Array/cls|) &rest argl)
+(dm |M::new| ((co |Array/cls|) &rest argl)
   (declare (ignorable co))
   (let ((inst (make-instance \'|Array/cls|)))
@@ -277 +284 @@
           (make-array (length argl) :adjustable t :initial-contents argl))
     inst))
-)
 
 ;; Hack until Str, Int, Num, etc are p6 objects.
-(eval \'(dm |M::Str| ((s string) &rest argl) (declare (ignorable argl)) s))
-(eval \'(dm |M::Str| ((n number) &rest argl) (declare (ignorable argl)) (write-to-string n)))
-(eval \'(dm |M::WHAT| ((s string) &rest argl) (declare (ignorable s argl)) "str"))
-(eval \'(dm |M::WHAT| ((n number) &rest argl) (declare (ignorable n argl)) "num"))
-
-(eval \'(dm |M::Str| ((x null) &rest argl) (declare (ignorable x argl)) ""))
-(eval \'(dm |M::WHAT| ((x null) &rest argl) (declare (ignorable x argl)) "nil"))
-(eval \'(dm |M::substr| ((s string) from len) (subseq s from (+ from len))))
+(dm |M::Str| ((s string) &rest argl) (declare (ignorable argl)) s)
+(dm |M::Str| ((n number) &rest argl) (declare (ignorable argl)) (write-to-string n))
+(dm |M::WHAT| ((s string) &rest argl) (declare (ignorable s argl)) "str")
+(dm |M::WHAT| ((n number) &rest argl) (declare (ignorable n argl)) "num")
+
+(dm |M::Str| ((x null) &rest argl) (declare (ignorable x argl)) "")
+(dm |M::WHAT| ((x null) &rest argl) (declare (ignorable x argl)) "nil")
+(dm |M::substr| ((s string) from len) (subseq s from (+ from len)))
 
 
@@ -322 +328 @@
 ;; to-n
 (defgeneric to-n (x))
+(defmethod to-s ((x null)) 0) ;X unboxed Undef
 (defmethod to-n ((x number)) x)
 (defmethod to-n ((x |Int/cls|)) (slot-value x \'|Int::._native_|))
@@ -328 +335 @@
 ;; to-s
 (defgeneric to-s (x))
+(defmethod to-s ((x null)) "") ;X unboxed Undef
 (defmethod to-s ((x string)) x)
 (defmethod to-s ((x |Str/cls|)) (slot-value x \'|Str::._native_|))
@@ -384 +392 @@
     $n.do_all_analysis();
     my $decls = $n.notes<lexical_variable_decls>;
-    my $code = "(let (\n";
+    my $code = "";
+    my $lexicals = "";
+    my $lexicals_foot = "";
     $decls.map(sub($d){if $d.scope eq 'my' {
-      #$code = $code ~ $.e($d.var)~" "; #X SubDecl :/
-      # ~$d.twigil~ not included because STD_red is using 0 as false,
-      #   and the 0 is mutating into a '0'.  Switch to undef?
-      $code = $code ~ $.qsym($d.sigil~$d.name)~" ";
+      $lexicals = $lexicals ~ $.qsym($d.sigil~$d.name)~" ";
     }});
-    $code = $code ~")\n";
+    if $lexicals {
+      $code = $code~"(let (\n"~$lexicals ~")\n";
+      $lexicals_foot = ")";
+    }
     temp $whiteboard::in_package = [];
     temp $whiteboard::emit_pairs_inline = 0;
@@ -403 +413 @@
     my $foot = $whiteboard::compunit_footer.join("\n");
     my $blk_head = $whiteboard::block_header.join("");
-    $code ~ $declare ~ $blk_head ~ $head ~ $stmts ~$foot~"\n)\n";
+    $code ~ $declare ~ $blk_head ~ $head ~ $stmts ~$foot~"\n"~$lexicals_foot~"\n";
   }
   method cb__Block ($n) {
@@ -410 +420 @@
     temp $whiteboard::block_header = [];
     my $decls = $n.notes<lexical_variable_decls>;
-    my $code = "(let (";
+    my $code = "";
+    my $lexicals = "";
+    my $lexicals_foot = "";
     $decls.map(sub($d){
        my $scope = $d.scope;
        if $scope eq 'my' {
-         $code = $code ~ $.e($d.var)~" ";
+         $lexicals = $lexicals ~ $.e($d.var)~" ";
        }
        elsif $scope eq 'temp' {
          my $v = $.e($d.var);
-         $code = $code ~ "("~$v~" (if (boundp '"~$v~") "~$v~")) ";
+         $lexicals = $lexicals ~ "("~$v~" (if (boundp '"~$v~") "~$v~")) ";
        }
     });
+    if $lexicals {
+      $code = $code~"(let (\n"~$lexicals ~")\n";
+      $lexicals_foot = ")";
+    }
     my $stmts = $.e($n.statements).join("\n");
     my $declare = $whiteboard::declares.join("");
     my $blk_head = $whiteboard::block_header.join("");
-    $code~")\n"~$declare~$blk_head~$stmts~')'
+    $code~$declare~$blk_head~$stmts~$lexicals_foot;
   }
 
@@ -526 +542 @@
       my $accname = '|M::'~$name~'|';
       my $code =
-        ('(eval \'(dm '~$accname~' ((self '~$cls~'))'~
+        ('(dm '~$accname~' ((self '~$cls~'))'~
          ' (let ((setter (lambda (o v) (setf (slot-value o \''~$slotname~') v))))'~
-         '   (rw-able (slot-value self \''~$slotname~') setter self))))'~"\n");
+         '   (rw-able (slot-value self \''~$slotname~') setter self)))'~"\n");
       my $slot_specifier = '('~$slotname;
       if $default {
@@ -565 +581 @@
     my $enc_name = $.qsym('M::'~$.e($n.name));
     my $sig = $.e($n.multisig);
-    my $decl = ('(eval \'(dm '~$enc_name~' ((self '~$cls~') '~$sig~
-                ' (declare (ignorable self))'~
-                ' (block __f__ '~$body~')))');
-    $whiteboard::compunit_header.push($decl);
+    my $decl = ('(dm '~$enc_name~' ((self '~$cls~') '~$sig~
+                #' (let () (declare (ignorable self))'~
+                ' (block __f__ '~$body~'))');
+    $whiteboard::block_header.push($decl);
     "";
   }
@@ -611 +627 @@
       $code = '(lambda '~$most~')';
     }
-    $whiteboard::compunit_header.push($decl);
+    $whiteboard::block_header.push($decl);
     $code;
   }
@@ -663 +679 @@
       }
     }
-    my $call = '(fc '~$meth~' '~$invocant~' '~$e_capture~')';
-    $call;
+    if $n.capture.contains_a_list {
+      '(ap '~$meth~' (cons '~$invocant~' (flatten-lists '~$e_capture~')))';
+    }
+    else {
+      '(fc '~$meth~' '~$invocant~' '~$e_capture~')';
+    }
   }
   method fqsym ($name) {
@@ -763 +783 @@
     }
 
+    if not(defined($e_capture)) { $e_capture = $.e($n.capture) }
+    my $pre = '(fc ';
+    my $mid = ' ';
+    my $post = ')';
+    if $n.capture.contains_a_list {
+      $pre = '(ap ';
+      $mid = ' (flatten-lists ';
+      $post = '))';
+    }
+
     if $fun.re_matchp('^\w') {
       my $fe = $.qsym('GLOBAL::&'~$fun);
-      if not(defined($e_capture)) { $e_capture = $.e($n.capture) }
-      return '(fc '~$fe~' '~$e_capture~')'
+      return $pre~$fe~$mid~$e_capture~$post;
     }
     if $fun.re_matchp('^[$@%&]') {
-       return  '(fc '~$.qsym($fun)~' '~$.e($n.capture)~')';
+       return  $pre~$.qsym($fun)~$mid~$e_capture~$post;
     }
     else {
-       return  '(fc '~$fun~' '~$.e($n.capture)~')';
+       return $pre~$fun~$mid~$e_capture~$post;
     }
   }

misc/elfish/on_sbcl/Makefile

@@ -1 +1 @@
 
+ELF=../../elf/elf_h
+ELFDIR=../../elf/elf_h_src
+TMP=deleteme
+SBCL=sbcl --dynamic-space-size 1800
 
 elfx:: have_parser_cache
-        ELF_STD_RED_RUN=../../STD_red/STD_red_run ../../elf/elf_h -x -o ./elfx -I ../../elf/elf_h_src Elf_SBCL.pm
+        ELF_STD_RED_RUN=../../STD_red/STD_red_run ../../elf/elf_h -x -o ./elfx -I ../../elf/elf_h_src -e 'use Elf_wo_main' EmitSBCL.pm -e elf_main
 
-#XXX no main() call yet, so CommandLine must come after last file...
-# but doesnt here.
-#       ELF_STD_RED_RUN=../../STD_red/STD_red_run ../../elf/elf_h -x -o ./elfx -I ../../elf/elf_h_src Elf.pm EmitSBCL.pm
-
-
+elfcl:: have_parser_cache
+        ${ELF} -I ${ELFDIR} EmitSBCL.pm -x -o elfcl Elf_SBCL.pm
+        time ${SBCL} --eval '(compile-file "elfcl")' --eval '(quit)' >& elfcl.out
 
 have_parser_cache:
@@ -46 +48 @@
         ./lib-cl_compile.lisp
 
+check: have_parser_cache
+        -mkdir ${TMP}
+        -rm ${TMP}/[ab]*
+        # Create a p5 elf.
+        ${ELF} -I ${ELFDIR} -x -o ${TMP}/a0 ${ELFDIR}/Elf.pm
+        # Create a CL elf.
+        ${ELF} -I ${ELFDIR} EmitSBCL.pm -x -o ${TMP}/b0 Elf_SBCL.pm
+        # Compile it, with output to log.
+        ${SBCL} --disable-debugger --eval '(compile-file "${TMP}/b0")' --eval '(quit)' > ${TMP}/b0.log 2>&1
+        # Run it.
+        chmod a+x ${TMP}/b0
+        ${TMP}/b0 -e 'say 3'
+        # Check CL bootstrap.
+        ${TMP}/b0 -I ${ELFDIR} -x -o ${TMP}/b1 Elf_SBCL.pm
+        diff ${TMP}/b0 ${TMP}/b1
+        # Compile a p5 elf with a CL one.
+        ${TMP}/b0 -I ${ELFDIR} -e 'use EmitSimpleP5' -x -o ${TMP}/a1 -e 'use Elf'
+        # Was it identical?
+        diff ${TMP}/a0 ${TMP}/a1

misc/elfish/on_sbcl/PrimitivesSBCL.pm

@@ -146 +146 @@
   sub private_tidy ($s) { $s }
   sub eval_runtime_code($code,$env) is cl {'
-    (eval (read-from-string (S |$code|)))
+    (eval (read-from-string (concatenate \'string "(progn " (S |$code|) ")")))
   '}
   sub file_exists ($filename) is cl {'
     (UP (if (probe-file (S |$filename|)) t nil))
   '}
+  sub elf_main () { Program.new().main(@*ARGS); }
 }
 # regexp elf bootstrap primitives
@@ -158 +159 @@
     (multiple-value-bind (match_str a) (ppcre::scan-to-strings (S |$re|) (S self))
       (declare (ignorable match_str))
-      (new-Array (mapcar #\'UP a)))
+      (new-Array (mapcar #\'UP (coerce a \'list))))
   '}
   method re_gsub ($re,$replacement_str) is cl {'

misc/elfish/on_sbcl/README

@@ -36 +36 @@
 NOTES
 
+  SBCL is a verbose beast.  Anything which compiles should be run
+  from a fast terminal.  Like xterm, not gnome terminal.  Otherwise,
+  terminal scrolling will determine compile time.
+
+  Compiling the CL elf requires about 2GB of ram.
+
   Warnings are sometimes muffled before check in, to improve the
   experience of causal users.  For real development, comment out
@@ -62 +68 @@
   # This remained 1x with general rw-ability added, still native integers.
   # This dropped to 1/2x with Int's.
+  # This dropped to 1/4x while not being watched, for causes unknown.