From d88787027d4a1c0e54a62083fca4c8b38b9f13aa Mon Sep 17 00:00:00 2001
From: Ilya Rezvov <ilya.rezvov@revjet.com>
Date: Wed, 23 May 2018 15:03:03 -0700
Subject: [PATCH] store only unique constants

---
 rts/index.html          | 184 +++++++++++++++++++++++++++++++++++-----
 src/IRTS/CodegenWasm.hs |  73 +++++++++++++---
 2 files changed, 228 insertions(+), 29 deletions(-)

diff --git a/rts/index.html b/rts/index.html
index 231cc5d..aa0b4cf 100644
--- a/rts/index.html
+++ b/rts/index.html
@@ -1,5 +1,6 @@
 <script>
     let mem = null
+    let alloc = null
 
     const ValType = {
         Con: 0,
@@ -18,50 +19,183 @@
             case ValType.Con:
                 return { type: 'con', size, tag: mem.getUint32(addr + 8, true), addr }
             case ValType.Int:
-                return { type: 'int', val: mem.getUint32(addr + 8, true), addr }
+                return { type: 'int', size, val: mem.getInt32(addr + 8, true), addr }
+            case ValType.Bit32:
+                return { type: 'bit32', size, val: mem.getInt32(addr + 8, true), addr }
+            case ValType.Bit64:
+                return {
+                    type: 'bit64',
+                    size,
+                    val: [mem.getInt32(addr + 8, true), mem.getInt32(addr + 12, true)],
+                    addr
+                }
+            case ValType.BigInt:
+                return {
+                    type: 'big',
+                    size,
+                    val: [mem.getInt32(addr + 8, true), mem.getInt32(addr + 12, true)],
+                    addr
+                }
             case ValType.Float:
-                return { type: 'float', val: mem.getFloat64(addr + 8, true), addr }
+                return { type: 'float', size, val: mem.getFloat64(addr + 8, true), addr }
             case ValType.String:
+                const len = mem.getUint32(addr + 8, true)
                 return {
                     type: 'string',
                     size,
-                    len: mem.getUint32(addr + 8, true),
-                    val: mem.buffer.slice(addr + 12, size - 12),
+                    len,
+                    val: readString(addr + 12, len),
                     addr
                 }
             default:
-                throw new Error('Unknown value')
+                throw new Error('Unknown value. Type tag: ' + mem.getUint8(addr))
         }
     }
 
+    function loadString(addr) {
+        const len = mem.getUint32(addr + 8, true)
+        return readString(addr + 12, len)
+    }
+
+    function aligned(size) {
+        return (size + 3) & 0xFFFFFFFC
+    }
+
     function gc(requestedSize) {
         console.log('gc', requestedSize)
     }
 
     function strEq(a, b) {
-        console.log('str eq', loadValue(a), loadValue(b))
-        return 0
+        if (a === b) {
+            return makeInt(1)
+        }
+        const strA = loadString(a)
+        const strB = loadString(b)
+        const res = makeInt(strA === strB ? 1 : 0)
+        console.log('str eq', loadValue(a), loadValue(b), loadValue(res))
+        return res
     }
 
     function strHead(strAddr) {
-        console.log('str head', loadValue(strAddr))
-        return 0
+        const head = readString(strAddr + 12, 1)
+        const res = makeString(head)
+        console.log('str head', loadValue(strAddr), head, loadValue(res))
+        return res
     }
 
     function strConcat(a, b) {
-        console.log('str concat', loadValue(a), loadValue(b))
-        return 0
+        const va = loadValue(a)
+        const vb = loadValue(b)
+        const res = makeString(va.val + vb.val)
+        console.log('str concat', va, vb, loadValue(res))
+        return res
     }
 
     function strWrite(strAddr) {
         console.log('str write', loadValue(strAddr))
-        console.log(strAddr)
-        return 0
+        console.log(loadString(strAddr))
+        return makeInt(0)
+    }
+
+    function getCharWidth(code) {
+        if (code < 0x80) {
+            return 1
+        }
+        if (code >= 0x80 && code < 0x800) {
+            return 2
+        }
+        if (code >= 0x800 && code < 0x8000) {
+            return 3
+        }
+        return 4
     }
 
-    function intStr(i) {
-        console.log('int to str', loadValue(i))
-        return 0
+    function getStringSizeInBytes(str) {
+        let size = 0
+        for (let i = 0; i < str.length; i++) {
+            size += getCharWidth(str.charCodeAt(i))
+        }
+        return size
+    }
+
+    function writeChar(dst, code) {
+        const width = getCharWidth(code)
+        switch (width) {
+            case 1:
+                mem.setUint8(dst, code)
+                break
+            case 2:
+                mem.setUint8(dst, (code >> 6) | 0xC0)
+                mem.setUint8(dst + 1, (code & 0x3F) | 0x80)
+                break
+            case 3:
+                mem.setUint8(dst, (code >> 12) | 0xE0)
+                mem.setUint8(dst + 1, ((code >> 6) & 0x3F) | 0x80)
+                mem.setUint8(dst + 2, (code & 0x3F) | 0x80)
+                break
+            default:
+                mem.setUint8(dst, (code >> 18) | 0xF0)
+                mem.setUint8(dst + 1, ((code >> 12) & 0x3F) | 0x80)
+                mem.setUint8(dst + 2, ((code >> 6) & 0x3F) | 0x80)
+                mem.setUint8(dst + 3, (code & 0x3F) | 0x80)
+        }
+        return width
+    }
+
+    function readString(addr, len) {
+        const codes = new Array(len)
+        for (let i = 0, next = addr; i < len; i++) {
+            const byte = mem.getUint8(next)
+            if ((byte & 0x80) == 0) { // one byte width
+                codes[i] = byte
+                next += 1
+            }
+            else if ((byte & 0xE0) == 0xC0) { // two bytes width
+                codes[i] = byte & 0x1F << 6
+                    | (mem.getUint8(addr + 1) & 0x3F)
+                next += 2
+            }
+            else if ((byte & 0xF0) == 0xE0) { // three bytes width
+                codes[i] = byte & 0x0F << 12
+                    | ((mem.getUint8(addr + 1) & 0x3F) << 6)
+                    | (mem.getUint8(addr + 2) & 0x3F)
+                next += 3
+            }
+            else { // four bytes width
+                codes[i] = byte & 0x07 << 18
+                | ((mem.getUint8(addr + 1) & 0x3F) << 12)
+                | ((mem.getUint8(addr + 2) & 0x3F) << 6)
+                | (mem.getUint8(addr + 3) & 0x3F)
+                next += 4
+            }
+        }
+        return String.fromCharCode.apply(String, codes)
+    }
+
+    function makeString(str) {
+        const size = 12 + getStringSizeInBytes(str)
+        const addr = alloc(size)
+        mem.setUint8(addr, ValType.String)
+        mem.setUint8(addr + 1, !str ? 1 : 0)
+        mem.setUint32(addr + 8, str.length, true)
+        for (let i = 0, cur = addr + 12; i <= str.length; i++) {
+            cur += writeChar(cur, str.charCodeAt(i))
+        }
+        return addr
+    }
+
+    function makeInt(val) {
+        const addr = alloc(12)
+        mem.setUint8(addr, ValType.Int)
+        mem.setInt32(addr + 8, val, true)
+        return addr
+    }
+
+    function intStr(intAddr) {
+        const val = mem.getUint32(intAddr + 8, true) | 0
+        const res = makeString(val.toString())
+        console.log('int to str', loadValue(intAddr), loadValue(res))
+        return res
     }
 
     function raiseError(strAddr) {
@@ -69,6 +203,17 @@
         throw new Error('Idris Error')
     }
 
+    function printConstSection(end) {
+        const vals = []
+        let i = 0
+        while (i < end) {
+            const val = loadValue(i)
+            vals.push(val)
+            i += aligned(val.size)
+        }
+        console.log('CONST SECTION', vals)
+    }
+
     fetch('fact.wasm').then(response =>
         response.arrayBuffer()
     ).then(bytes => {
@@ -76,9 +221,10 @@
             rts: { raiseError, gc, strEq, strHead, strConcat, strWrite, intStr }
         })
     }).then(results => {
-        console.log('result', results)
-        const {alloc, mem: m, main, stackStart} = results.instance.exports
+        const {alloc: a, mem: m, main, stackStart} = results.instance.exports
         mem = new DataView(m.buffer)
+        alloc = a
+        printConstSection(stackStart)
         main(stackStart)
-    }).catch(err => console.log('wasm error', err));
+    })
 </script>
\ No newline at end of file
diff --git a/src/IRTS/CodegenWasm.hs b/src/IRTS/CodegenWasm.hs
index 2385b78..eb0779a 100644
--- a/src/IRTS/CodegenWasm.hs
+++ b/src/IRTS/CodegenWasm.hs
@@ -45,7 +45,6 @@ mkWasm defs stackSize heapSize =
         raiseError <- importFunction "rts" "raiseError" (FuncType [I32] [])
         strEq <- importFunction "rts" "strEq" (FuncType [I32, I32] [I32])
         strHead <- importFunction "rts" "strHead" (FuncType [I32] [I32])
-        strConcat <- importFunction "rts" "strConcat" (FuncType [I32, I32] [I32])
         strWrite <- importFunction "rts" "strWrite" (FuncType [I32] [I32])
         intStr <- importFunction "rts" "intStr" (FuncType [I32] [I32])
         exportMemory "mem" =<< memory 20 Nothing
@@ -120,6 +119,28 @@ mkWasm defs stackSize heapSize =
                 (const $ for (i .= stackTop) (i `lt_u` newStackTop) (i .= (i `add` i32c 4)) $ const $ do
                     store i (i32c 0) 0 2
                 )
+        memcpy <- fun $ do
+            dst <- param i32
+            src <- param i32
+            len <- param i32
+            i <- local i32
+            for (i .= i32c 0) (i `lt_u` len) (i .= (i `add` i32c 1)) $ const $ do
+                store8 (dst `add` i) (load8u i32 (src `add` i) 0 0) 0 0
+        strConcat <- fun $ do
+            a <- param i32
+            b <- param i32
+            result i32
+            aSize <- local i32
+            bSize <- local i32
+            addr <- local i32
+            aSize .= load i32 a 4 2
+            bSize .= load i32 b 4 2
+            addr .= call i32 alloc [aSize `add` bSize `sub` i32c 12]
+            store8 addr (i32c $ fromEnum String) 0 0
+            store addr (load i32 a 8 2 `add` load i32 b 8 2) 8 2
+            invoke memcpy [arg (addr `add` i32c 12), arg (a `add` i32c 12), arg (aSize `sub` i32c 12)]
+            invoke memcpy [arg (addr `add` aSize), arg (b `add` i32c 12), arg (bSize `sub` i32c 12)]
+            ret addr
         defsStartFrom <- nextFuncIndex
         let bindings = GB {
                 stackStartIdx = stackStart,
@@ -158,11 +179,14 @@ mkWasm defs stackSize heapSize =
 data GenState = GS {
     constSectionEnd :: Word32,
     constSection :: BSBuilder.Builder,
-    strCache :: Map.Map String Word32
+    strCache :: Map.Map String Word32,
+    intCache :: Map.Map Int Word32,
+    bigCache :: Map.Map Integer Word32,
+    doubleCache :: Map.Map Double Word32
 }
 
 emptyState :: GenState
-emptyState = GS 0 mempty mempty
+emptyState = GS 0 mempty mempty mempty mempty mempty
 
 data GlobalBindings = GB {
     stackBaseIdx :: Glob I32,
@@ -576,23 +600,51 @@ asAddr expr = do
     return $ i32c addr
 
 makeConst :: Const -> WasmGen (GenFun (Proxy I32))
-makeConst (I i) = asAddr $ addToConstSection (mkInt i)
-makeConst (BI i) = asAddr $ addToConstSection (mkBigInt i)
-makeConst (Fl f) = asAddr $ addToConstSection (mkFloat f)
-makeConst (Ch c) = asAddr $ addToConstSection (mkInt $ Char.ord c)
+makeConst (I i) = makeIntConst i
+makeConst (BI i) = do
+    cache <- gets bigCache
+    case Map.lookup i cache of
+        Just addr -> return $ i32c addr
+        Nothing -> do
+            addr <- addToConstSection (mkBigInt i)
+            modify $ \st -> st { bigCache = Map.insert i addr cache }
+            return $ i32c addr
+makeConst (Fl f) = do
+    cache <- gets doubleCache
+    case Map.lookup f cache of
+        Just addr -> return $ i32c addr
+        Nothing -> do
+            addr <- addToConstSection (mkFloat f)
+            modify $ \st -> st { doubleCache = Map.insert f addr cache }
+            return $ i32c addr
+makeConst (Ch c) = makeIntConst $ Char.ord c
 makeConst (Str s) = do
     cache <- gets strCache
     case Map.lookup s cache of
         Just addr -> return $ i32c addr
-        Nothing -> asAddr $ addToConstSection (mkStr s)
-makeConst (B8 w) = asAddr $ addToConstSection (mkInt w)
-makeConst (B16 w) = asAddr $ addToConstSection (mkInt w)
+        Nothing -> do
+            addr <- addToConstSection (mkStr s)
+            modify $ \st -> st { strCache = Map.insert s addr cache }
+            return $ i32c addr
+makeConst (B8 w) = makeIntConst w
+makeConst (B16 w) = makeIntConst w
 makeConst (B32 w) = asAddr $ addToConstSection (mkBit32 w)
 makeConst (B64 w) = asAddr $ addToConstSection (mkBit64 w)
 makeConst c
     | isTypeConst c = asAddr $ addToConstSection (mkInt 42424242)
     | otherwise = error $ "mkConst of (" ++ show c ++ ") not implemented"
 
+makeIntConst :: (Integral i) => i -> WasmGen (GenFun (Proxy I32))
+makeIntConst val = do
+    let i = fromIntegral val
+    cache <- gets intCache
+    case Map.lookup i cache of
+        Just addr -> return $ i32c addr
+        Nothing -> do
+            addr <- addToConstSection (mkInt i)
+            modify $ \st -> st { intCache = Map.insert i addr cache }
+            return $ i32c addr
+
 aligned :: (Integral i) => i -> Word32
 aligned sz = (fromIntegral sz + 3) .&. 0xFFFFFFFC
 
@@ -701,6 +753,7 @@ instance Serialize.Serialize StrVal where
     put SV { hdr, len, val } = do
         Serialize.put hdr
         Serialize.putWord32le len
+        Serialize.putLazyByteString val
     get = do
         hdr <- Serialize.get
         len <- Serialize.getWord32le