From db29f6d193988ebef66ecabdead0fd8f2ed3087d Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Tue, 26 Nov 2019 21:24:25 +0100
Subject: Use Sequence-based string in VM; 50% faster lispparser.lisp

---
 VM.hs | 25 +++++++++++++------------
 1 file changed, 13 insertions(+), 12 deletions(-)

(limited to 'VM.hs')

diff --git a/VM.hs b/VM.hs
index bed0596..7812afd 100644
--- a/VM.hs
+++ b/VM.hs
@@ -10,6 +10,7 @@ import qualified System.IO.Error as IO
 -- import Debug.Trace
 
 import AST
+import qualified DString as DS
 import Intermediate
 
 
@@ -33,7 +34,7 @@ data RunValue
     = RVClosure Name [RunValue]
     | RVList [RunValue]
     | RVNum Int
-    | RVString String
+    | RVString DS.DString
     | RVQuoted RunValue
     | RVName Name
   deriving Show
@@ -142,7 +143,7 @@ vmRunBuiltin state "cons" [val, RVList l] = return (RVList (val : l), state)
 vmRunBuiltin state "sys-open-file" [RVNum modenum, RVString path] = do
     let mode = [ReadMode, WriteMode] !! modenum
         fid = sUniq state
-    handle <- openFile path mode
+    handle <- openFile (DS.unpack path) mode
     return (RVNum fid, state { sHandles = Map.insert fid handle (sHandles state), sUniq = fid + 1 })
 vmRunBuiltin state "sys-close-file" [RVNum fid] = do
     hClose (sHandles state ! fid)
@@ -152,9 +153,9 @@ vmRunBuiltin state "sys-get-char" [RVNum fid] = do
     eof <- hIsEOF h
     if eof
         then return (RVList [], state)
-        else hGetChar h >>= \ch -> return (RVString [ch], state)
+        else hGetChar h >>= \ch -> return (RVString (DS.singleton ch), state)
 vmRunBuiltin state "sys-put-string" [RVNum fid, RVString str] = do
-    hPutStr (sHandles state ! fid) str
+    DS.hPutStr (sHandles state ! fid) str
     return (RVList [], state)
 vmRunBuiltin state "sys-flush" [RVNum fid] = do
     hFlush (sHandles state ! fid)
@@ -162,14 +163,14 @@ vmRunBuiltin state "sys-flush" [RVNum fid] = do
 vmRunBuiltin state "sys-stdin" [] = return (RVNum (-1), state)
 vmRunBuiltin state "sys-stdout" [] = return (RVNum (-2), state)
 vmRunBuiltin state "sys-stderr" [] = return (RVNum (-3), state)
-vmRunBuiltin state "length" [RVString str] = return (RVNum (length str), state)
+vmRunBuiltin state "length" [RVString str] = return (RVNum (DS.length str), state)
 vmRunBuiltin state "substr" [RVNum idx, RVNum len, RVString str] =
-    let s = (if len >= 0 then take len else id) (drop idx str)
+    let s = (if len >= 0 then DS.take len else id) (DS.drop idx str)
     in return (RVString s, state)
-vmRunBuiltin state "ord" [RVString str] = return (RVNum (case str of { "" -> 0; c:_ -> ord c }), state)
-vmRunBuiltin state "chr" [RVNum num] = return (RVString [chr num], state)
+vmRunBuiltin state "ord" [RVString str] = return (RVNum (if DS.null str then 0 else ord (DS.head str)), state)
+vmRunBuiltin state "chr" [RVNum num] = return (RVString (DS.singleton (chr num)), state)
 vmRunBuiltin state "concat" values
-    | Just strings <- sequence (map fromRVString values) = return (RVString (concat strings), state)
+    | Just strings <- sequence (map fromRVString values) = return (RVString ({-# SCC builtin_string_concat #-} DS.concat strings), state)
     | otherwise = throw "Non-string arguments to 'concat'"
 vmRunBuiltin state "type-list?" [value]   = return (RVNum (case value of { RVList _   -> 1; _ -> 0 }), state)
 vmRunBuiltin state "type-number?" [value] = return (RVNum (case value of { RVNum _    -> 1; _ -> 0 }), state)
@@ -192,7 +193,7 @@ equalOp (RVName n) (RVName m) = Right (n == m)
 equalOp _ _ = Right False
 
 printshow :: RunValue -> String
-printshow (RVString str) = str
+printshow (RVString str) = DS.unpack str
 printshow (RVList values) = "[" ++ intercalate "," (map printshow values) ++ "]"
 printshow (RVNum i) = show i
 printshow (RVQuoted value) = '\'' : printshow value
@@ -206,7 +207,7 @@ truthy _ = True
 toRunValue :: Value -> RunValue
 toRunValue (VList values) = RVList (map toRunValue values)
 toRunValue (VNum i) = RVNum i
-toRunValue (VString s) = RVString s
+toRunValue (VString s) = RVString (DS.pack s)
 toRunValue (VQuoted value) = RVQuoted (toRunValue value)
 toRunValue (VName name) = RVName name
 toRunValue _ = undefined
@@ -214,6 +215,6 @@ toRunValue _ = undefined
 throw :: String -> IO a
 throw s = hPutStrLn stderr s >> IO.ioError (IO.userError kErrorExit)
 
-fromRVString :: RunValue -> Maybe String
+fromRVString :: RunValue -> Maybe DS.DString
 fromRVString (RVString str) = Just str
 fromRVString _ = Nothing
-- 
cgit v1.2.3-54-g00ecf