From cf7b7db0e4040c17e05f851fd0e9d79bc173aafd Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Thu, 21 Nov 2019 20:45:27 +0100
Subject: Tail call optimisation

---
 VM.hs | 34 ++++++++++++++++++----------------
 1 file changed, 18 insertions(+), 16 deletions(-)

(limited to 'VM.hs')

diff --git a/VM.hs b/VM.hs
index fb79ebd..b66cfc5 100644
--- a/VM.hs
+++ b/VM.hs
@@ -60,7 +60,7 @@ vmRunBB info state (BB _ inss term) = do
 
 vmRunInstr :: Info -> State -> Instruction -> IO State
 -- vmRunInstr _ _ ins | traceShow ins False = undefined
-vmRunInstr info@(Info bbmap gfds datas) state@(State { sTempMap = tmap, sArgs = args, sCloVals = closure }) (dest, instr) = case instr of
+vmRunInstr info@(Info _ _ datas) state@(State { sTempMap = tmap, sArgs = args, sCloVals = closure }) (dest, instr) = case instr of
     IAssign ref -> return (assignRef state dest (findRef tmap ref))
     IParam i ->
         if i < length args then return (assignRef state dest (args !! i))
@@ -71,21 +71,9 @@ vmRunInstr info@(Info bbmap gfds datas) state@(State { sTempMap = tmap, sArgs =
     IData i ->
         if i < length datas then return (assignRef state dest (toRunValue (datas !! i)))
             else error "data-out-of-range"
-    ICallC cl as ->
-        -- trace ("callc " ++ show (findRef tmap cl) ++ "  " ++ show (map (findRef tmap) as)) $
-        case findRef tmap cl of
-            RVClosure clname clvals -> case Map.lookup clname gfds of
-                Just (GlobFuncDef b _ _) ->
-                    let Just bb = Map.lookup b bbmap
-                    in do
-                        -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as))
-                        (rv, _) <- vmRunBB info (state { sArgs = map (findRef tmap) as, sCloVals = clvals }) bb
-                        return (assignRef state dest rv)
-                Nothing -> do
-                    -- Take 'tail as' to skip the first self-link argument
-                    (rv, state') <- vmRunBuiltin state clname (map (findRef tmap) (tail as))
-                    return (assignRef state' dest rv)
-            obj -> error $ "VM: Cannot call non-closure object: " ++ show obj
+    ICallC cl as -> do
+        (rv, state') <- callClosure info state cl as
+        return (assignRef state' dest rv)
     IAllocClo name clrefs -> return (assignRef state dest (RVClosure name (map (findRef tmap) clrefs)))
     IDiscard _ -> return state
 
@@ -94,6 +82,7 @@ vmRunTerm info@(Info bbmap _ _) state@(State { sTempMap = tmap }) term = case te
     IBr ref b1 b2 -> vmRunBB info state . (bbmap !) $ if truthy (findRef tmap ref) then b1 else b2
     IJmp b -> vmRunBB info state (bbmap ! b)
     IRet ref -> return (findRef tmap ref, state)
+    ITailC cl as -> callClosure info state cl as
     IExit -> IO.ioError (IO.userError kErrorExit)
     IUnknown -> undefined
 
@@ -107,6 +96,19 @@ assignRef :: State -> Ref -> RunValue -> State
 assignRef state (RTemp i) rv = state { sTempMap = Map.insert i rv (sTempMap state) }
 assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned"
 
+callClosure :: Info -> State -> Ref -> [Ref] -> IO (RunValue, State)
+callClosure info@(Info bbmap gfds _) state@(State { sTempMap = tmap }) cl as =
+    case findRef tmap cl of
+        RVClosure clname clvals -> case Map.lookup clname gfds of
+            Just (GlobFuncDef b _ _) -> do
+                (rv, state') <- vmRunBB info (state { sArgs = map (findRef tmap) as, sCloVals = clvals })
+                                        (bbmap Map.! b)
+                return (rv, state' { sArgs = sArgs state, sCloVals = sCloVals state })
+            Nothing ->
+                -- Take 'tail as' to skip the first self-link argument
+                vmRunBuiltin state clname (map (findRef tmap) (tail as))
+        obj -> error $ "VM: Cannot call non-closure object: " ++ show obj
+
 vmRunBuiltin :: State -> Name -> [RunValue] -> IO (RunValue, State)
 -- vmRunBuiltin _ name args | trace (name ++ " " ++ show args) False = undefined
 vmRunBuiltin state "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList [], state)
-- 
cgit v1.2.3-70-g09d2