content: module Data.Bedrock.Invoke () where {-
      ( lowerInvoke ) where
  
  import           Control.Monad.State
  import qualified Data.IntSet             as IntSet
  -- import           Data.List
  import qualified Data.Map                as Map
  import qualified Data.Vector             as Vector
  
  import           Data.Bedrock
  import           Data.Bedrock.Exceptions (isCatchFrame)
  import           Data.Bedrock.HPT
  import           Data.Bedrock.Misc
  import           Data.Bedrock.Transform
  
  
  -- Lower calls to @Invoke and @InvokeHandler
  lowerInvoke :: HPTResult -> Gen ()
  lowerInvoke hpt = do
      fs <- gets (Map.elems . envFunctions)
      forM_ fs $ \fn -> do
          body' <- traverseBlock hpt fn (fnBody fn)
          pushFunction fn
              { fnBody = body'
              }
      return ()
  
  
  traverseBlock :: HPTResult -> Function -> Block -> Gen Block
  traverseBlock hpt origin block =
      case block of
          Bind binds simple rest ->
              Bind
                  (map (setVariableSize hpt) binds)
                  (traverseExpression hpt simple)
                  <$> traverseBlock hpt origin rest
          Case scrut defaultBranch alternatives ->
              Case scrut
                  <$> maybe (return Nothing) (fmap Just . traverseBlock hpt origin) defaultBranch
                  <*> mapM (traverseAlternative hpt origin) alternatives
          Invoke obj args ->
              Case (setVariableSize hpt obj) Nothing
                  <$> mkInvokeAlts hpt (hptNodeScope hpt Vector.! variableIndex obj) args
          -- InvokeHandler obj arg ->
          --     Case (setVariableSize hpt obj) Nothing
          --         <$> mkInvokeHandlerAlts hpt (hptNodeScope hpt Vector.! variableIndex obj) arg
          other -> return other
  
  traverseExpression :: HPTResult -> Expression -> Expression
  traverseExpression hpt expr =
      case expr of
          Store node vars -> Store node (map (setVariableSize hpt) vars)
          Fetch ptr -> Fetch ptr
          _ -> expr
  
  -- FIXME: merge with HPT
  derefPtrs :: HPTResult -> NameSet -> HeapLocationSet
  derefPtrs hpt ptrs = heapLocationSetUnions
      [ hptPtrScope hpt Vector.! ptr
      | ptr <- IntSet.toList ptrs ]
  
  -- FIXME: merge with HPT
  -- derefVars :: HPTResult -> NameSet -> Objects
  -- derefVars hpt vars = mergeObjectList
  --     [ hptNodeScope hpt Vector.! var
  --     | var <- IntSet.toList vars ]
  
  -- FIXME: merge with HPT
  derefHeap :: HPTResult -> HeapLocationSet -> Objects
  derefHeap hpt (HeapLocationSet vars) = mergeObjectList
      [ hptHeap hpt Vector.! hp
      | hp <- IntSet.toList vars ]
  
  mkInvokeAlts :: HPTResult -> Objects -> [Variable] -> Gen [Alternative]
  mkInvokeAlts hpt objects args = do
      let mkAlt (name@(FunctionName fn blanks), _objArgs)
                  | blanks == length args = do
              let partialArgs = dropLast blanks $ hptFnArgs hpt Map.! fn
              return $
                  Alternative (NodePat name partialArgs) $
                  TailCall fn (map (setVariableSize hpt) $
                      partialArgs ++ args)
          mkAlt (ConstructorName cons 0, objArgs) | isCatchFrame cons = do
              let nextFramePtrs = objArgs Vector.! 0
                  nextFrameLocs = derefPtrs hpt nextFramePtrs
                  nextFrameObjects = derefHeap hpt nextFrameLocs
              nextFramePtr <- newVariable "nextFrame" NodePtr
              nextFrame <- newVariable "nextFrame" (StaticNode (sizeOfObjects hpt nextFrameObjects))
              exhPtr <- newVariable "exhPtr" Node
              Alternative (NodePat (ConstructorName cons 0) [nextFramePtr, exhPtr]) .
                  Bind [nextFrame] (Fetch nextFramePtr) .
                  Case nextFrame Nothing
                      <$> mkInvokeAlts hpt nextFrameObjects args
  
          mkAlt (alt, _args) =
              return $ Alternative (NodePat alt []) (Panic "Invoke failure")
  
      mapM mkAlt (Map.toList objects)
  
  -- mkInvokeHandlerAlts :: HPTResult -> Objects -> Variable -> Gen [Alternative]
  -- mkInvokeHandlerAlts hpt objects arg = do
  --     let mkAlt (name@(FunctionName fn blanks), objArgs) = do
  --             let partialArgs = dropLast blanks $ hptFnArgs hpt Map.! fn
  --                 isFrameVariable Variable{variableType=FramePtr{}} = True
  --                 isFrameVariable _ = False
  --             case findIndex isFrameVariable partialArgs of
  --                 Nothing ->
  --                     return $
  --                         Alternative (NodePat name partialArgs) $
  --                         Panic "Couldn't find frame pointer."
  --                 Just framePtrIndex -> do
  --                     let nextFramePtrs = objArgs Vector.! framePtrIndex
  --                         nextFrameLocs = derefPtrs hpt nextFramePtrs
  --                         nextFrameObjects = derefHeap hpt nextFrameLocs
  --                         size = sizeOfObjects hpt nextFrameObjects
  --                     let nextFramePtr = partialArgs !! framePtrIndex
  --                     nextFrame <- newVariable "nextFrame" (StaticNode size)
  --                     Alternative (NodePat name partialArgs) .
  --                         Bind [nextFrame] (Fetch nextFramePtr) .
  --                         Case nextFrame Nothing
  --                             <$> mkInvokeHandlerAlts hpt nextFrameObjects arg
  --         mkAlt (ConstructorName cons 0, objArgs) | isCatchFrame cons = do
  --             let exhVars = objArgs Vector.! 1
  --                 exhObjects = derefVars hpt exhVars
  --             nextFramePtr <- newVariable "nextFrame" NodePtr
  --             exh <- newVariable "exh" (StaticNode (sizeOfObjects hpt exhObjects))
  --             Alternative (NodePat (ConstructorName cons 0) [nextFramePtr, exh]) .
  --                 Case exh Nothing
  --                     <$> mkInvokeAlts hpt exhObjects [arg, nextFramePtr]
  --
  --         mkAlt (alt, _args) =
  --             return $ Alternative (NodePat alt []) (Panic "Invoke handler failure")
  --
  --     mapM mkAlt (Map.toList objects)
  
  
  traverseAlternative :: HPTResult -> Function -> Alternative -> Gen Alternative
  traverseAlternative hpt origin alternative =
      case alternative of
          Alternative pattern branch ->
              Alternative pattern <$> traverseBlock hpt origin branch
  -}
  