location info in nodes

anoma · Jan 26, 2024 · 2e1647d · 2e1647d
1 parent c672555
commit 2e1647d
Show file tree

Hide file tree

Showing 11 changed files with 292 additions and 152 deletions.
diff --git a/src/Juvix/Compiler/Asm/Translation/FromTree.hs b/src/Juvix/Compiler/Asm/Translation/FromTree.hs
@@ -71,18 +71,18 @@ genCode fi =
       snocReturn isTail $
         DL.snoc (go False _nodeUnopArg) (genUnOp _nodeUnopOpcode)
 
-    goConstant :: Bool -> Tree.Constant -> Code'
-    goConstant isTail c =
+    goConstant :: Bool -> Tree.NodeConstant -> Code'
+    goConstant isTail Tree.NodeConstant {..} =
       snocReturn isTail $
         DL.singleton $
           mkInstr $
-            Push (Constant c)
+            Push (Constant _nodeConstant)
 
-    goMemRef :: Bool -> Tree.MemRef -> Code'
-    goMemRef isTail ref =
+    goMemRef :: Bool -> Tree.NodeMemRef -> Code'
+    goMemRef isTail Tree.NodeMemRef {..} =
       snocReturn isTail $
         DL.singleton $
-          mkInstr (Push (Ref ref))
+          mkInstr (Push (Ref _nodeMemRef))
 
     goAllocConstr :: Bool -> Tree.NodeAllocConstr -> Code'
     goAllocConstr isTail Tree.NodeAllocConstr {..} =
@@ -212,7 +212,7 @@ genCode fi =
         ( Save
             CmdSave
               { _cmdSaveInfo = emptyInfo,
-                _cmdSaveName = _nodeSaveTempVarInfo ^. Tree.tempVarInfoName,
+                _cmdSaveName = _nodeSaveTempVar ^. Tree.tempVarName,
                 _cmdSaveIsTail = isTail,
                 _cmdSaveCode = DL.toList $ go isTail _nodeSaveBody
               }

diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs
@@ -11,13 +11,15 @@ import GHC.Show qualified as S
 import Juvix.Compiler.Core.Data.BinderList qualified as BL
 import Juvix.Compiler.Tree.Data.InfoTable
 import Juvix.Compiler.Tree.Error
+import Juvix.Compiler.Tree.Extra.Base
 import Juvix.Compiler.Tree.Language
 import Juvix.Compiler.Tree.Language.Value
 import Juvix.Compiler.Tree.Pretty
 import Text.Read qualified as T
 
-newtype EvalError = EvalError
-  { _evalErrorMsg :: Text
+data EvalError = EvalError
+  { _evalErrorLocation :: Maybe Location,
+    _evalErrorMsg :: Text
   }
 
 makeLenses ''EvalError
@@ -53,7 +55,7 @@ hEval hout tab = eval' [] mempty
       where
         evalError :: Text -> a
         evalError msg =
-          Exception.throw (EvalError (msg <> ": " <> ppTrace tab node))
+          Exception.throw (EvalError (getNodeLocation node) msg)
 
         goBinop :: NodeBinop -> Value
         goBinop NodeBinop {..} =
@@ -127,16 +129,16 @@ hEval hout tab = eval' [] mempty
         goTrace :: Value -> Value
         goTrace v = unsafePerformIO (hPutStrLn hout (printValue v) >> return v)
 
-        goConstant :: Constant -> Value
-        goConstant = \case
+        goConstant :: NodeConstant -> Value
+        goConstant NodeConstant {..} = case _nodeConstant of
           ConstInt i -> ValInteger i
           ConstBool b -> ValBool b
           ConstString s -> ValString s
           ConstUnit -> ValUnit
           ConstVoid -> ValVoid
 
-        goMemRef :: MemRef -> Value
-        goMemRef = \case
+        goMemRef :: NodeMemRef -> Value
+        goMemRef NodeMemRef {..} = case _nodeMemRef of
           DRef r -> goDirectRef r
           ConstrRef r -> goField r
 
@@ -266,21 +268,23 @@ hEval hout tab = eval' [] mempty
 
 valueToNode :: Value -> Node
 valueToNode = \case
-  ValInteger i -> Const $ ConstInt i
-  ValBool b -> Const $ ConstBool b
-  ValString s -> Const $ ConstString s
-  ValUnit -> Const ConstUnit
-  ValVoid -> Const ConstVoid
+  ValInteger i -> mkConst $ ConstInt i
+  ValBool b -> mkConst $ ConstBool b
+  ValString s -> mkConst $ ConstString s
+  ValUnit -> mkConst ConstUnit
+  ValVoid -> mkConst ConstVoid
   ValConstr Constr {..} ->
     AllocConstr
       NodeAllocConstr
-        { _nodeAllocConstrTag = _constrTag,
+        { _nodeAllocConstrInfo = mempty,
+          _nodeAllocConstrTag = _constrTag,
           _nodeAllocConstrArgs = map valueToNode _constrArgs
         }
   ValClosure Closure {..} ->
     AllocClosure
       NodeAllocClosure
-        { _nodeAllocClosureFunSymbol = _closureSymbol,
+        { _nodeAllocClosureInfo = mempty,
+          _nodeAllocClosureFunSymbol = _closureSymbol,
           _nodeAllocClosureArgs = map valueToNode _closureArgs
         }
 
@@ -298,7 +302,8 @@ hRunIO hin hout infoTable = \case
     let code =
           CallClosures
             NodeCallClosures
-              { _nodeCallClosuresFun = valueToNode f,
+              { _nodeCallClosuresInfo = mempty,
+                _nodeCallClosuresFun = valueToNode f,
                 _nodeCallClosuresArgs = valueToNode x' :| []
               }
         !x'' = hEval hout infoTable code
@@ -327,5 +332,5 @@ toTreeError :: EvalError -> TreeError
 toTreeError EvalError {..} =
   TreeError
     { _treeErrorMsg = "evaluation error: " <> _evalErrorMsg,
-      _treeErrorLoc = Nothing
+      _treeErrorLoc = _evalErrorLocation
     }
diff --git a/src/Juvix/Compiler/Tree/Extra/Base.hs b/src/Juvix/Compiler/Tree/Extra/Base.hs
@@ -3,10 +3,34 @@ module Juvix.Compiler.Tree.Extra.Base where
 import Juvix.Compiler.Tree.Language
 
 mkBinop :: BinaryOpcode -> Node -> Node -> Node
-mkBinop op arg1 arg2 = Binop (NodeBinop op arg1 arg2)
+mkBinop op arg1 arg2 = Binop (NodeBinop mempty op arg1 arg2)
 
 mkUnop :: UnaryOpcode -> Node -> Node
-mkUnop op arg = Unop (NodeUnop op arg)
+mkUnop op arg = Unop (NodeUnop mempty op arg)
+
+mkConst :: Constant -> Node
+mkConst c = Const $ NodeConstant mempty c
+
+mkMemRef :: MemRef -> Node
+mkMemRef r = MemRef $ NodeMemRef mempty r
+
+getNodeInfo :: Node -> NodeInfo
+getNodeInfo = \case
+  Binop NodeBinop {..} -> _nodeBinopInfo
+  Unop NodeUnop {..} -> _nodeUnopInfo
+  Const NodeConstant {..} -> _nodeConstantInfo
+  MemRef NodeMemRef {..} -> _nodeMemRefInfo
+  AllocConstr NodeAllocConstr {..} -> _nodeAllocConstrInfo
+  AllocClosure NodeAllocClosure {..} -> _nodeAllocClosureInfo
+  ExtendClosure NodeExtendClosure {..} -> _nodeExtendClosureInfo
+  Call NodeCall {..} -> _nodeCallInfo
+  CallClosures NodeCallClosures {..} -> _nodeCallClosuresInfo
+  Branch NodeBranch {..} -> _nodeBranchInfo
+  Case NodeCase {..} -> _nodeCaseInfo
+  Save NodeSave {..} -> _nodeSaveInfo
+
+getNodeLocation :: Node -> Maybe Location
+getNodeLocation = (^. nodeInfoLocation) . getNodeInfo
 
 {------------------------------------------------------------------------}
 {- generic Node destruction -}
@@ -15,7 +39,7 @@ data NodeChild = NodeChild
   { -- | immediate child of some node
     _childNode :: Node,
     -- | `Just i` if the child introduces a temporary variable
-    _childTempVarInfo :: Maybe TempVarInfo
+    _childTempVar :: Maybe TempVar
   }
 
 makeLenses ''NodeChild
@@ -38,15 +62,15 @@ noTempVar :: Node -> NodeChild
 noTempVar n =
   NodeChild
     { _childNode = n,
-      _childTempVarInfo = Nothing
+      _childTempVar = Nothing
     }
 
 {-# INLINE oneTempVar #-}
-oneTempVar :: TempVarInfo -> Node -> NodeChild
+oneTempVar :: TempVar -> Node -> NodeChild
 oneTempVar i n =
   NodeChild
     { _childNode = n,
-      _childTempVarInfo = Just i
+      _childTempVar = Just i
     }
 
 type Reassemble = [Node] -> Node
@@ -101,7 +125,8 @@ destruct = \case
             NodeBinop
               { _nodeBinopArg1 = arg1,
                 _nodeBinopArg2 = arg2,
-                _nodeBinopOpcode
+                _nodeBinopOpcode,
+                _nodeBinopInfo
               }
       }
   Unop NodeUnop {..} ->
@@ -111,7 +136,8 @@ destruct = \case
           Unop
             NodeUnop
               { _nodeUnopArg = arg,
-                _nodeUnopOpcode
+                _nodeUnopOpcode,
+                _nodeUnopInfo
               }
       }
   Const c ->
@@ -131,7 +157,8 @@ destruct = \case
           AllocConstr
             NodeAllocConstr
               { _nodeAllocConstrArgs = args,
-                _nodeAllocConstrTag
+                _nodeAllocConstrTag,
+                _nodeAllocConstrInfo
               }
       }
   AllocClosure NodeAllocClosure {..} ->
@@ -141,7 +168,8 @@ destruct = \case
           AllocClosure
             NodeAllocClosure
               { _nodeAllocClosureArgs = args,
-                _nodeAllocClosureFunSymbol
+                _nodeAllocClosureFunSymbol,
+                _nodeAllocClosureInfo
               }
       }
   ExtendClosure NodeExtendClosure {..} ->
@@ -151,7 +179,8 @@ destruct = \case
           ExtendClosure
             NodeExtendClosure
               { _nodeExtendClosureArgs = nonEmpty' args,
-                _nodeExtendClosureFun = arg
+                _nodeExtendClosureFun = arg,
+                _nodeExtendClosureInfo
               }
       }
   Call NodeCall {..} -> case _nodeCallType of
@@ -162,7 +191,8 @@ destruct = \case
             Call
               NodeCall
                 { _nodeCallArgs = args,
-                  _nodeCallType = CallFun sym
+                  _nodeCallType = CallFun sym,
+                  _nodeCallInfo
                 }
         }
     CallClosure cl ->
@@ -172,7 +202,8 @@ destruct = \case
             Call
               NodeCall
                 { _nodeCallArgs = args,
-                  _nodeCallType = CallClosure arg
+                  _nodeCallType = CallClosure arg,
+                  _nodeCallInfo
                 }
         }
   CallClosures NodeCallClosures {..} ->
@@ -182,7 +213,8 @@ destruct = \case
           CallClosures
             NodeCallClosures
               { _nodeCallClosuresArgs = nonEmpty' args,
-                _nodeCallClosuresFun = arg
+                _nodeCallClosuresFun = arg,
+                _nodeCallClosuresInfo
               }
       }
   Branch NodeBranch {..} ->
@@ -193,7 +225,8 @@ destruct = \case
             NodeBranch
               { _nodeBranchArg = arg,
                 _nodeBranchTrue = br1,
-                _nodeBranchFalse = br2
+                _nodeBranchFalse = br2,
+                _nodeBranchInfo
               }
       }
   Case NodeCase {..} ->
@@ -207,7 +240,8 @@ destruct = \case
                   { _nodeCaseArg = v',
                     _nodeCaseBranches = mkBranches _nodeCaseBranches bodies',
                     _nodeCaseDefault = Nothing,
-                    _nodeCaseInductive
+                    _nodeCaseInductive,
+                    _nodeCaseInfo
                   }
           }
       Just def ->
@@ -219,27 +253,29 @@ destruct = \case
                   { _nodeCaseArg = v',
                     _nodeCaseBranches = mkBranches _nodeCaseBranches bodies',
                     _nodeCaseDefault = Just def',
-                    _nodeCaseInductive
+                    _nodeCaseInductive,
+                    _nodeCaseInfo
                   }
           }
     where
       branchChildren = map mkBranchChild _nodeCaseBranches
 
       mkBranchChild :: CaseBranch -> NodeChild
       mkBranchChild CaseBranch {..} =
-        (if _caseBranchSave then oneTempVar (TempVarInfo Nothing Nothing) else noTempVar) _caseBranchBody
+        (if _caseBranchSave then oneTempVar (TempVar Nothing Nothing) else noTempVar) _caseBranchBody
 
       mkBranches :: [CaseBranch] -> [Node] -> [CaseBranch]
       mkBranches = zipWithExact (flip (set caseBranchBody))
   Save NodeSave {..} ->
     NodeDetails
-      { _nodeChildren = [noTempVar _nodeSaveArg, oneTempVar _nodeSaveTempVarInfo _nodeSaveBody],
+      { _nodeChildren = [noTempVar _nodeSaveArg, oneTempVar _nodeSaveTempVar _nodeSaveBody],
         _nodeReassemble = twoChildren $ \arg body ->
           Save
             NodeSave
               { _nodeSaveArg = arg,
                 _nodeSaveBody = body,
-                _nodeSaveTempVarInfo
+                _nodeSaveTempVar,
+                _nodeSaveInfo
               }
       }
 

diff --git a/src/Juvix/Compiler/Tree/Extra/Recursors/Base.hs b/src/Juvix/Compiler/Tree/Extra/Recursors/Base.hs
@@ -17,14 +17,14 @@ import Juvix.Compiler.Tree.Extra.Base
 import Juvix.Compiler.Tree.Extra.Recursors.Recur
 import Juvix.Compiler.Tree.Language
 
-instance IsNodeChild NodeChild TempVarInfo where
-  gBindersNum = fromEnum . isJust . (^. childTempVarInfo)
-  gBinders = toList . (^. childTempVarInfo)
+instance IsNodeChild NodeChild TempVar where
+  gBindersNum = fromEnum . isJust . (^. childTempVar)
+  gBinders = toList . (^. childTempVar)
 
 instance IsNodeDetails NodeDetails NodeChild where
   gChildren = (^. nodeChildren)
 
-instance IsNode Node NodeDetails NodeChild TempVarInfo where
+instance IsNode Node NodeDetails NodeChild TempVar where
   gDestruct = destruct
   gReassemble = reassembleDetails
   gChild = (^. childNode)