tco working, update playground to self-hosted newt

Makefile

@@ -1,6 +1,10 @@
 OSRCS=$(shell find orig -name "*.idr")
 SRCS=$(shell find src -name "*.newt")
 
+# Node shaves off 40% of the time.
+# RUNJS=bun run
+RUNJS=node
+
 .PHONY:
 
 all: build/exec/newt build/exec/newt.js build/exec/newt.min.js newt.js
@@ -25,13 +29,13 @@ orig_test: build/exec/newt
 # New version
 
 newt.js: ${SRCS}
-	bun run bootstrap/newt.js src/Main.newt -o newt.js
+	$(RUNJS) bootstrap/newt.js src/Main.newt -o newt.js
 
 newt2.js: newt.js
-	bun run newt.js src/Main.newt -o newt2.js
+	$(RUNJS) newt.js src/Main.newt -o newt2.js
 
 newt3.js: newt2.js
-	bun run newt2.js src/Main.newt -o newt3.js
+	$(RUNJS) newt2.js src/Main.newt -o newt3.js
 	cmp newt2.js newt3.js
 
 test: newt.js

playground/build

@@ -6,6 +6,6 @@ echo build newt worker
 esbuild src/worker.ts --bundle --format=esm > public/worker.js
 esbuild src/frame.ts --bundle --format=esm > public/frame.js
 echo copy newt
-cp ../build/exec/newt.js public
+cp ../newt.js public
 cp -r static/* public
 (cd samples && zip -r ../public/files.zip .)

playground/src/emul.ts

@@ -1,62 +1,5 @@
 import { ZipFile } from "./zipfile";
 
-class Buffer extends DataView {
-  static alloc(n: number) {
-    return new Buffer(new Uint8Array(n).buffer);
-  }
-  indexOf(n: number) {
-    return new Uint8Array(this.buffer).indexOf(n);
-  }
-  get length() {
-    return this.byteLength;
-  }
-  slice(start: number, end: number) {
-    return new Buffer(this.buffer.slice(start, end));
-  }
-  readUInt8(i: number) {
-    return this.getUint8(i);
-  }
-  writeUInt8(val: number, i: number) {
-    this.setUint8(i, val);
-  }
-  write(value: string, start: number, len: number, enc: string) {
-    // console.log("write", value, start, len, enc);
-    let buf = new TextEncoder().encode(value);
-    let ss = 0;
-    let se = Math.min(len, buf.length);
-    let ts = start;
-    for (; ss < se; ss++, ts++) this.setInt8(ts, buf[ss]);
-    shim.process.__lasterr.errno = 0;
-    return se;
-  }
-  readDoubleLE(i: number) {
-    return this.getFloat64(i, true);
-  }
-  readInt32LE(i: number) {
-    return this.getInt32(i, true);
-  }
-  writeInt32LE(val: number, i: number) {
-    return this.setInt32(i, val, true);
-  }
-  copy(target: Buffer, ts: number, ss: number, se: number) {
-    for (; ss < se; ss++, ts++) target.setInt8(ts, this.getInt8(ss));
-  }
-  static concat(bufs: Buffer[]) {
-    let size = bufs.reduce((a, b) => (a += b.byteLength), 0);
-    let rval = Buffer.alloc(size);
-    let off = 0;
-    for (let buf of bufs) {
-      const view = new Int8Array(rval.buffer);
-      view.set(new Uint8Array(buf.buffer), off);
-      off += buf.byteLength;
-    }
-    return rval;
-  }
-  toString() {
-    return new TextDecoder().decode(this);
-  }
-}
-
 export interface Handle {
   name: string;
   mode: string;
@@ -65,28 +8,14 @@ export interface Handle {
 }
 
 interface Process {
-  platform: string;
-  stdout: {
-    write(s: string): void;
-  };
   argv: string[];
   exit(_: number): void;
-  cwd(): string;
-  env: Record<string, string>;
-  __lasterr: { errno: number };
 }
 export interface NodeShim {
   stdout: string;
   archive?: ZipFile;
   process: Process;
   files: Record<string, Uint8Array>;
-  fds: Handle[];
-  tty: {
-    isatty(): number;
-  };
-  os: {
-    platform(): string;
-  };
   fs: any;
 }
 export let shim: NodeShim = {
@@ -94,153 +23,32 @@ export let shim: NodeShim = {
   archive: undefined,
   stdout: "",
   files: {},
-  fds: [],
-  tty: {
-    isatty() {
-      return 0;
-    },
-  },
-  os: {
-    platform() {
-      return "linux";
-    },
-  },
   fs: {
-    // TODO - Idris is doing readdir, we should implement that
+    readFileSync(name: string, encoding: string, enc?: string) {
-    opendirSync(name: string) {
+      if (name.startsWith("./")) name = name.slice(2);
-      let fd = shim.fds.findIndex((x) => !x);
+      let data: Uint8Array | undefined = shim.files[name]
-      if (fd < 0) fd = shim.fds.length;
+      if (!data && shim.archive?.entries[name]) {
-      console.log("openDir", name);
+        // keep a copy of the uncompressed version for speed
-      shim.process.__lasterr.errno = 0;
+        data = shim.files[name] = shim.archive.getData(name)!;
-      return fd;
+      }
-    },
+      if (data) {
-    mkdirSync(name: string) {
+        return new TextDecoder().decode(data);
-      console.log("mkdir", name);
-      shim.process.__lasterr.errno = 0;
-      return 0;
-    },
-    openSync(name: string, mode: string) {
-      console.log("open", name, mode);
-      if (name.startsWith('./')) name = name.slice(2)
-      let te = new TextEncoder();
-
-      let fd = shim.fds.findIndex((x) => !x);
-      if (fd < 0) fd = shim.fds.length;
-      let buf: Uint8Array;
-      let pos = 0;
-      if (mode == "w") {
-        buf = new Uint8Array(0);
       } else {
-        // TODO, we need to involve localStorage when the window does multiple files and persists
+        throw new Error(`${name} not found`);
-        if (shim.files[name]) {
-          buf = shim.files[name];
-        } else if (shim.archive?.entries[name]) {
-          // keep a copy of the uncompressed version for speed
-          buf = shim.files[name] = shim.archive.getData(name)!;
-        } else {
-          shim.process.__lasterr.errno = 1;
-          throw new Error(`${name} not found`);
-        }
-      }
-      shim.process.__lasterr.errno = 0;
-      shim.fds[fd] = { buf, pos, mode, name };
-      // we'll mutate the pointer as stuff is read
-      return fd;
-    },
-    writeSync(fd: number, line: string | Buffer) {
-      try {
-        let handle = shim.fds[fd];
-        if (!handle) throw new Error(`bad fd ${fd}`);
-
-        let buf2: ArrayBuffer;
-        if (typeof line === "string") {
-          buf2 = new TextEncoder().encode(line);
-          let newbuf = new Uint8Array(handle.buf.byteLength + buf2.byteLength);
-          newbuf.set(new Uint8Array(handle.buf));
-          newbuf.set(new Uint8Array(buf2), handle.buf.byteLength);
-          handle.buf = newbuf;
-          shim.process.__lasterr.errno = 0;
-        } else if (line instanceof Buffer) {
-          let start = arguments[2];
-          let len = arguments[3];
-          buf2 = line.buffer.slice(start, start + len);
-          let newbuf = new Uint8Array(handle.buf.byteLength + buf2.byteLength);
-          newbuf.set(new Uint8Array(handle.buf));
-          newbuf.set(new Uint8Array(buf2), handle.buf.byteLength);
-          handle.buf = newbuf;
-          shim.process.__lasterr.errno = 0;
-          return len;
-        } else {
-          debugger;
-          throw new Error(`write ${typeof line} not implemented`);
-        }
-      } catch (e) {
-        debugger;
-        throw e;
       }
     },
-    chmodSync(fn: string, mode: number) {},
+    writeFileSync(name: string, data: string, enc?: string) {
-    fstatSync(fd: number) {
+      shim.files[name] = new TextEncoder().encode(data)
-      let hand = shim.fds[fd];
-      return { size: hand.buf.byteLength };
-    },
-    readSync(fd: number, buf: Buffer, start: number, len: number) {
-      let hand = shim.fds[fd];
-      let avail = hand.buf.length - hand.pos;
-      let rd = Math.min(avail, len);
-      let src = hand.buf;
-      let dest = new Uint8Array(buf.buffer);
-      for (let i = 0; i < rd; i++) dest[start + i] = src[hand.pos++];
-      return rd;
-    },
-    closeSync(fd: number) {
-      let handle = shim.fds[fd];
-      // console.log("close", handle.name);
-      if (handle.mode == "w") {
-        shim.files[handle.name] = handle.buf;
-      }
-      delete shim.fds[fd];
     },
   },
   process: {
-    platform: "linux",
     argv: ["", ""],
-    stdout: {
-      write(s) {
-        shim.stdout += s;
-      },
-    },
     exit(v: number) {
-      console.log("exit", v);
+      throw new Error(`exit ${v}`)
     },
-    cwd() {
+  }
-      return "";
-    },
-    env: {
-      NO_COLOR: "true",
-      IDRIS2_CG: "javascript",
-      IDRIS2_PREFIX: "",
-    },
-    __lasterr: {
-      errno: 0,
-    },
-    // stdin: { fd: 0 },
-  },
 };
 
-// Spy on Idris' calls to see what we need to fill in
-shim.fs = new Proxy(shim.fs, {
-  get(target, prop, receiver) {
-    if (prop in target) {
-      return (target as any)[prop];
-    }
-    let err = new Error(`IMPLEMENT fs.${String(prop)}`);
-    // idris support eats the exception
-    console.error(err);
-    throw err;
-  },
-});
-
 // we intercept require to return our fake node modules
 declare global {
   interface Window {

playground/src/global.d.ts

@@ -6,5 +6,5 @@ declare global {
 
   // let files: Record<string, string>;
   // let process: Process;
-  let newtMain: () => unknown;
+  let Main_main: () => unknown;
 }

playground/src/preload.ts

@@ -8,8 +8,6 @@ export let preload = (async function () {
       let data = await res.arrayBuffer();
       archive = new ZipFile(new Uint8Array(data));
       let entries = archive.entries;
-      let count = Object.keys(entries).length;
-      console.log(`preloaded ${count} files`);
     } else {
       console.error(
         `fetch of files.zip got status ${res.status}: ${res.statusText}`

playground/src/worker.ts

@@ -2,20 +2,23 @@ import { shim } from "./emul";
 import { archive, preload } from "./preload";
 import { CompileReq, CompileRes } from "./types";
 
+console.log = (m) => {
+  shim.stdout += '\n' + m
+}
+
 const handleMessage = async function (ev: { data: CompileReq }) {
   console.log("message", ev.data);
   await preload;
   shim.archive = archive;
   let { src, fileName } = ev.data;
   const outfile = "out.js";
-  shim.process.argv = ["", "", fileName, "-o", outfile, "--top"];
+  shim.process.argv = ["browser", "newt", fileName, "-o", outfile, "--top"];
-  console.log("Using args", shim.process.argv);
   shim.files[fileName] = new TextEncoder().encode(src);
   shim.files[outfile] = new TextEncoder().encode("No JS output");
   shim.stdout = "";
   const start = +new Date();
   try {
-    newtMain();
+    Main_main();
   } catch (e) {
     // make it clickable in console
     console.error(e);

src/Lib/Compile.newt

@@ -126,7 +126,7 @@ termToJS env (CBnd k) f = case getAt (cast k) env.jsenv of
   (Just e) => f e
   Nothing => fatalError "Bad bounds"
 termToJS env CErased f = f JUndefined
-termToJS env (CRaw str) f = f (Raw str)
+termToJS env (CRaw str _) f = f (Raw str)
 termToJS env (CLam nm t) f =
   let (nm',env') = freshName' nm env -- "\{nm}$\{show $ length env}"
   in f $ JLam (nm' :: Nil) (termToJS env' t JReturn)
@@ -334,18 +334,37 @@ getEntries acc name = do
 -- sort names by dependencies
 -- In JS this is only really needed for references that don't fall
 -- under a lambda.
-sortedNames : SortedMap QName Def → QName → List QName
+sortedNames : SortedMap QName CExp → QName → List QName
 sortedNames defs qn = go Nil Nil qn
   where
+    getBody : CAlt → CExp
+    getBody (CConAlt _ _ t) = t
+    getBody (CLitAlt _ t) = t
+    getBody (CDefAlt t) = t
+
+    getNames : List QName → CExp →  List QName
+    getNames acc (CLam _ t) = getNames acc t
+    getNames acc (CFun _ t) = getNames acc t
+    getNames acc (CApp t ts _) = foldl getNames acc (t :: ts)
+    getNames acc (CCase t alts) = foldl getNames acc $ t :: map getBody alts
+    getNames acc (CRef qn) = qn :: acc
+    getNames acc (CLet _ t u) = getNames (getNames acc t) u
+    getNames acc (CLetRec _ t u) = getNames (getNames acc t) u
+    getNames acc (CConstr _ ts) = foldl getNames acc ts
+    getNames acc (CRaw _ deps) = deps ++ acc
+    -- wrote these out so I get an error when I add a new constructor
+    getNames acc (CLit _) = acc
+    getNames acc (CMeta _) = acc
+    getNames acc (CBnd _) = acc
+    getNames acc CErased = acc
+
     go : List QName → List QName → QName → List QName
     go loop acc qn =
       -- O(n^2) it would be more efficient to drop qn from the map
       if elem qn loop || elem qn acc then acc else
       case lookupMap' qn defs of
         Nothing => acc
-        Just (Fn tm) => qn :: foldl (go $ qn :: loop) acc (getNames tm Nil)
+        Just exp => qn :: foldl (go $ qn :: loop) acc (getNames Nil exp)
-        Just (PrimFn src _ used) => qn :: foldl (go $ qn :: loop) acc used
-        Just def => qn :: acc
 
 eraseEntries : {{Ref2 Defs St}} → M Unit
 eraseEntries = do
@@ -372,11 +391,10 @@ process name = do
   eraseEntries
   liftWhere
   entries <- readIORef ref
-  let names = sortedNames entries name
   exprs <- mapM defToCExp $ toList entries
   let cexpMap = foldMap const EmptyMap exprs
-  -- TCO here on cexpMap
+  cexpMap <- tailCallOpt cexpMap
-  tailCallOpt cexpMap
+  let names = sortedNames cexpMap name
   pure $ map cexpToDoc $ mapMaybe (\x => lookupMap x cexpMap) names
 
 compile : M (List Doc)

src/Lib/CompileExp.newt

@@ -41,7 +41,7 @@ data CExp : U where
   -- Data / type constructor
   CConstr : Name -> List CExp -> CExp
   -- Raw javascript for `pfunc`
-  CRaw : String -> CExp
+  CRaw : String -> List QName -> CExp
 
 -- I'm counting Lam in the term for arity.  This matches what I need in
 -- code gen.
@@ -160,5 +160,5 @@ defToCExp (qn, Axiom)          = pure $ (qn, CErased)
 defToCExp (qn, DCon arity _)   = pure $ (qn, compileDCon qn arity)
 defToCExp (qn, TCon arity _)   = pure $ (qn, compileDCon qn arity)
 defToCExp (qn, PrimTCon arity) = pure $ (qn, compileDCon qn arity)
-defToCExp (qn, PrimFn src _ _) = pure $ (qn, CRaw src)
+defToCExp (qn, PrimFn src _ deps) = pure $ (qn, CRaw src deps)
 defToCExp (qn, Fn tm)          = (_,_ qn) <$> compileFun tm

src/Lib/TCO.newt

@@ -8,17 +8,17 @@ import Lib.Types
 import Lib.CompileExp
 import Data.SortedMap
 
--- We need CompileExp here, so we know if it's
+/-
--- fully applied, needs eta, etc.
+  This is modeled after Idris' tail call optimization written by Stefan Hoeck.
--- Maybe we should move Ref2 Defs over to CExp?
--- But we'll need CExp for constructors, etc.
--- I _could_ collect a stack and look up arity, but
--- at the next stage, we'd need to fake up constructor
--- records
 
+  We collect strongly connected components of the tail call graph,
+  defunctionalize it (make a data type modelling function calls and "return"),
+  and wrap it in a trampoline.
+
+-/
+
+-- Find names of applications in tail position
 tailNames : CExp → List QName
--- This is tricky, we need to skip the first CLam, but
--- a deeper one is a return value
 tailNames (CApp (CRef name) args 0) = name :: Nil
 tailNames (CCase _ alts) = join $ map altTailNames alts
   where
@@ -28,7 +28,7 @@ tailNames (CCase _ alts) = join $ map altTailNames alts
     altTailNames (CLitAlt _ exp) = tailNames exp
 tailNames (CLet _ _ t) = tailNames t
 tailNames (CLetRec _ _ t) = tailNames t
-tailNames (CConstr _ args) = Nil -- join $ map tailNames args
+tailNames (CConstr _ args) = Nil
 tailNames (CBnd _) = Nil
 tailNames (CFun _ tm) = tailNames tm
 tailNames (CLam _ _) = Nil
@@ -38,35 +38,72 @@ tailNames (CRef _) = Nil
 tailNames CErased = Nil
 tailNames (CLit _) = Nil
 tailNames (CMeta _) = Nil
-tailNames (CRaw _) = Nil
+tailNames (CRaw _ _) = Nil
 
-/-
+-- rewrite tail calls to return an object
-(CFun ["_", "_", "_$2", "_$3"]
+rewriteTailCalls : List QName → CExp → CExp
-  (CCase (CBnd 0) [
+rewriteTailCalls nms tm = case tm of
-     (CConAlt "_::_" ["a$4", "_$5", "_$6"]
+  CApp (CRef nm) args 0 =>
-       (CApp (CRef "Prelude.reverse.go")
+      if elem nm nms
-          [(CBnd 6), (CBnd 5), (CApp (CRef "Prelude._::_") [(CErased), (CBnd 1), (CBnd 4)] 0), (CBnd 0)] 0)), (CConAlt "Nil" ["a$4"] (CBnd 2))]))
+        then CConstr (show nm) args
+        else CConstr "return" (tm :: Nil)
+  CLetRec nm t u => CLetRec nm t $ rewriteTailCalls nms u
+  CLet nm t u => CLet nm t $ rewriteTailCalls nms u
+  CCase sc alts => CCase sc $ map rewriteAlt alts
+  tm => CConstr "return" (tm :: Nil)
+  where
+      rewriteAlt : CAlt -> CAlt
+      rewriteAlt (CConAlt nm args t) = CConAlt nm args $ rewriteTailCalls nms t
+      rewriteAlt (CDefAlt t) = CDefAlt $ rewriteTailCalls nms t
+      rewriteAlt (CLitAlt lit t) = CLitAlt lit $ rewriteTailCalls nms t
 
--/
+-- the name of our trampoline
+bouncer : QName
+bouncer = QN Nil "bouncer"
 
+doOptimize : List (QName × CExp) → M (List (QName × CExp))
+doOptimize fns = do
+  splitFuns <- traverse splitFun fns
+  let nms = map fst fns
+  let alts = CConAlt "return" ("rval" :: Nil) (CBnd 0) :: map (mkAlt nms) splitFuns
+  recName <- mkRecName nms
+  let recfun = CFun ("arg" :: Nil) $ CCase (CBnd 0) alts
+  wrapped <- traverse (mkWrap recName) fns
+  pure $ (recName, recfun) :: wrapped
+  where
+    mkWrap : QName → QName × CExp → M (QName × CExp)
+    mkWrap recName (qn, CFun args _) = do
+      let arglen = length' args
+      let arg = CConstr (show qn) $ map (\k => CBnd (arglen - k - 1)) (range 0 arglen)
+      let body = CApp (CRef bouncer) (CRef recName :: arg :: Nil) 0
+      pure $ (qn, CFun args body)
+    mkWrap _ (qn, _) = error emptyFC "error in mkWrap: \{show qn} not a CFun"
+
+    mkRecName : List QName → M QName
+    mkRecName Nil = error emptyFC "INTERNAL ERROR: Empty List in doOptimize"
+    mkRecName (QN ns nm :: _) = pure $ QN ns "REC_\{nm}"
+
+    mkAlt : List QName → (QName × List Name × CExp) -> CAlt
+    mkAlt nms (qn, args, tm) = CConAlt (show qn) args (rewriteTailCalls nms tm)
+
+    splitFun : (QName × CExp) → M (QName × List Name × CExp)
+    splitFun (qn, CFun args body) = pure (qn, args, body)
+    splitFun (qn, _) = error emptyFC "TCO error: \{show qn} not a function"
 
 ExpMap : U
 ExpMap = SortedMap QName CExp
 
--- Need to switch everything to QName
 tailCallOpt : ExpMap → M ExpMap
 tailCallOpt expMap = do
-  putStrLn "TODO TCO"
+  let graph = map (bimap id tailNames) (toList expMap)
-  let blah = map (bimap id tailNames) (toList expMap)
+  let groups = tarjan graph
-  let out = tarjan blah
+  foldlM processGroup expMap groups
-  for (toList expMap) $ \ foo => case foo of
+  where
-    (qn, cexp) => do
+    doUpdate : ExpMap → QName × CExp → ExpMap
-      liftIO $ putStrLn "--- \{show qn}"
+    doUpdate acc (k,v) = updateMap k v acc
-      liftIO $ debugLog cexp
-      liftIO $ debugLog $ tailNames cexp
-  -- everything is pointing to itself, I don't want that unless it actually does..
-  for out $ \ names => liftIO $ debugLog names
-
-  -- liftIO $ debugLog out
-  pure expMap
 
+    processGroup : ExpMap → List QName → M ExpMap
+    processGroup expMap names = do
+      let pairs = mapMaybe (flip lookupMap expMap) names
+      updates <- doOptimize pairs
+      pure $ foldl doUpdate expMap updates

src/Main.newt

@@ -52,7 +52,8 @@ writeSource fn = do
   docs <- compile
   let src = unlines $
         ( "\"use strict\";"
-        ::  "const PiType = (h0, h1) => ({ tag: \"PiType\", h0, h1 })"
+        :: "const PiType = (h0, h1) => ({ tag: \"PiType\", h0, h1 });"
+        :: "const bouncer = (f,ini) => { let obj = ini; while (obj.tag !== 'return') obj = f(obj); return obj.h0 };"
         :: Nil)
         ++ map (render 90 ∘ noAlt) docs
   (Right _) <- liftIO {M} $ writeFile fn src
@@ -229,7 +230,7 @@ cmdLine (fn :: args) = do
 
 main' : M Unit
 main' = do
-  let (arg0 :: args) = getArgs
+  (arg0 :: args) <- liftIO {M} $ getArgs
     | _ => error emptyFC "error reading args"
   (out, files) <- cmdLine args
   traverse processFile files

src/Node.newt

@@ -2,8 +2,7 @@ module Node
 
 import Prelude
 
--- REVIEW - should this be IO (List String)
+pfunc getArgs uses (arrayToList MkIORes) :  IO (List String) := `(w) => Prelude_MkIORes(null, Prelude_arrayToList(null, process.argv.slice(1)), w)`
-pfunc getArgs uses (arrayToList) : List String := `Prelude_arrayToList(null, process.argv.slice(1))`
 pfunc readFile uses (MkIORes Left Right) : (fn : String) -> IO (Either String String) := `(fn) => (w) => {
   let fs = require('fs')
   let result