-- Copyright (C) 2018-2024 Jun Zhang <zhangjunphy[at]gmail[dot]com>
--
-- This file is a part of decafc.
--
-- decafc is free software: you can redistribute it and/or modify it under the
-- terms of the MIT (X11) License as described in the LICENSE file.
--
-- decafc is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE.  See the X11 license for more details.

module CFG.Build where

import AST qualified
import CFG.Types
import Control.Applicative (liftA2, (<|>))
import Control.Exception (throw)
import Control.Lens (use, uses, view, views, (%=), (%~), (&), (+=), (.=), (.~), (<~), (^.), _1, _2, _3, _Just)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Functor ((<&>))
import Data.Generics.Labels
import Data.List qualified as List
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Formatting
import GHC.Generics (Generic)
import SSA
import Semantic qualified as SE
import Types
import Util.Constants (globalScopeID)
import Util.Graph qualified as G
import Util.SourceLoc qualified as SL
import Data.Char (chr)

{------------------------------------------------
Data types
------------------------------------------------}
data SymVarMap = SymVarMap
  { SymVarMap -> Map Name ScopeID
m :: !(Map Name VID),
    SymVarMap -> Maybe ScopeID
parent :: !(Maybe ScopeID)
  }
  deriving (ScopeID -> SymVarMap -> ShowS
[SymVarMap] -> ShowS
SymVarMap -> [Char]
(ScopeID -> SymVarMap -> ShowS)
-> (SymVarMap -> [Char])
-> ([SymVarMap] -> ShowS)
-> Show SymVarMap
forall a.
(ScopeID -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: ScopeID -> SymVarMap -> ShowS
showsPrec :: ScopeID -> SymVarMap -> ShowS
$cshow :: SymVarMap -> [Char]
show :: SymVarMap -> [Char]
$cshowList :: [SymVarMap] -> ShowS
showList :: [SymVarMap] -> ShowS
Show, (forall x. SymVarMap -> Rep SymVarMap x)
-> (forall x. Rep SymVarMap x -> SymVarMap) -> Generic SymVarMap
forall x. Rep SymVarMap x -> SymVarMap
forall x. SymVarMap -> Rep SymVarMap x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SymVarMap -> Rep SymVarMap x
from :: forall x. SymVarMap -> Rep SymVarMap x
$cto :: forall x. Rep SymVarMap x -> SymVarMap
to :: forall x. Rep SymVarMap x -> SymVarMap
Generic)

data CFGState = CFGState
  { CFGState -> Maybe CFG
cfg :: !(Maybe CFG),
    CFGState -> ScopeID
astScope :: !ScopeID,
    CFGState -> ScopeID
currentBBID :: !BBID,
    CFGState -> [Var]
vars :: !VarList,
    CFGState -> Map ScopeID SymVarMap
sym2var :: !(Map ScopeID SymVarMap),
    CFGState -> Map ScopeID (ScopeID, Name)
var2sym :: !(Map VID (ScopeID, Name)),
    CFGState -> [SSA]
statements :: ![SSA],
    CFGState -> Maybe (ScopeID, ScopeID)
currentControlBlock :: !(Maybe (BBID, BBID)), -- entry and exit
    CFGState -> Maybe ScopeID
currentFunctionExit :: !(Maybe BBID),
    CFGState -> Maybe BasicBlock
globalBB :: !(Maybe BasicBlock)
  }
  deriving ((forall x. CFGState -> Rep CFGState x)
-> (forall x. Rep CFGState x -> CFGState) -> Generic CFGState
forall x. Rep CFGState x -> CFGState
forall x. CFGState -> Rep CFGState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CFGState -> Rep CFGState x
from :: forall x. CFGState -> Rep CFGState x
$cto :: forall x. Rep CFGState x -> CFGState
to :: forall x. Rep CFGState x -> CFGState
Generic)

data BBTransition
  = StayIn !BBID
  | TailAt !BBID
  | Deadend !BBID

initialState :: CFGState
initialState :: CFGState
initialState =
  CFGState
    { $sel:cfg:CFGState :: Maybe CFG
cfg = Maybe CFG
forall a. Maybe a
Nothing,
      $sel:astScope:CFGState :: ScopeID
astScope = ScopeID
0,
      $sel:currentBBID:CFGState :: ScopeID
currentBBID = ScopeID
0,
      $sel:vars:CFGState :: [Var]
vars = [],
      $sel:sym2var:CFGState :: Map ScopeID SymVarMap
sym2var = [(ScopeID, SymVarMap)] -> Map ScopeID SymVarMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ScopeID
0, Map Name ScopeID -> Maybe ScopeID -> SymVarMap
SymVarMap Map Name ScopeID
forall k a. Map k a
Map.empty Maybe ScopeID
forall a. Maybe a
Nothing)],
      $sel:var2sym:CFGState :: Map ScopeID (ScopeID, Name)
var2sym = Map ScopeID (ScopeID, Name)
forall k a. Map k a
Map.empty,
      $sel:statements:CFGState :: [SSA]
statements = [],
      $sel:currentControlBlock:CFGState :: Maybe (ScopeID, ScopeID)
currentControlBlock = Maybe (ScopeID, ScopeID)
forall a. Maybe a
Nothing,
      $sel:currentFunctionExit:CFGState :: Maybe ScopeID
currentFunctionExit = Maybe ScopeID
forall a. Maybe a
Nothing,
      $sel:globalBB:CFGState :: Maybe BasicBlock
globalBB = Maybe BasicBlock
forall a. Maybe a
Nothing
    }

{------------------------------------------------
Helps for CFGBuild monad
------------------------------------------------}
getCFG :: CFGBuild CFG
getCFG :: CFGBuild CFG
getCFG =
  Getting (Maybe CFG) CFGState (Maybe CFG) -> CFGBuild (Maybe CFG)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe CFG) CFGState (Maybe CFG)
#cfg CFGBuild (Maybe CFG) -> (Maybe CFG -> CFGBuild CFG) -> CFGBuild CFG
forall a b. CFGBuild a -> (a -> CFGBuild b) -> CFGBuild b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe CFG
Nothing -> CompileError -> CFGBuild CFG
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild CFG) -> CompileError -> CFGBuild CFG
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing Name
"CFG not initialized"
    Just CFG
cfg -> CFG -> CFGBuild CFG
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return CFG
cfg

setCFG :: CFG -> CFGBuild ()
setCFG :: CFG -> CFGBuild ()
setCFG CFG
cfg = (Maybe CFG -> Identity (Maybe CFG))
-> CFGState -> Identity CFGState
#cfg ((Maybe CFG -> Identity (Maybe CFG))
 -> CFGState -> Identity CFGState)
-> Maybe CFG -> CFGBuild ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= CFG -> Maybe CFG
forall a. a -> Maybe a
Just CFG
cfg

getGraph :: CFGBuild (G.Graph BBID BasicBlock CFGEdge)
getGraph :: CFGBuild (Graph ScopeID BasicBlock CFGEdge)
getGraph = CFGBuild CFG
getCFG CFGBuild CFG
-> (CFG -> Graph ScopeID BasicBlock CFGEdge)
-> CFGBuild (Graph ScopeID BasicBlock CFGEdge)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Getting
  (Graph ScopeID BasicBlock CFGEdge)
  CFG
  (Graph ScopeID BasicBlock CFGEdge)
-> CFG -> Graph ScopeID BasicBlock CFGEdge
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Graph ScopeID BasicBlock CFGEdge)
  CFG
  (Graph ScopeID BasicBlock CFGEdge)
#graph

setGraph :: G.Graph BBID BasicBlock CFGEdge -> CFGBuild ()
setGraph :: Graph ScopeID BasicBlock CFGEdge -> CFGBuild ()
setGraph Graph ScopeID BasicBlock CFGEdge
g = (Maybe CFG -> Identity (Maybe CFG))
-> CFGState -> Identity CFGState
#cfg ((Maybe CFG -> Identity (Maybe CFG))
 -> CFGState -> Identity CFGState)
-> ((Graph ScopeID BasicBlock CFGEdge
     -> Identity (Graph ScopeID BasicBlock CFGEdge))
    -> Maybe CFG -> Identity (Maybe CFG))
-> (Graph ScopeID BasicBlock CFGEdge
    -> Identity (Graph ScopeID BasicBlock CFGEdge))
-> CFGState
-> Identity CFGState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CFG -> Identity CFG) -> Maybe CFG -> Identity (Maybe CFG)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((CFG -> Identity CFG) -> Maybe CFG -> Identity (Maybe CFG))
-> ((Graph ScopeID BasicBlock CFGEdge
     -> Identity (Graph ScopeID BasicBlock CFGEdge))
    -> CFG -> Identity CFG)
-> (Graph ScopeID BasicBlock CFGEdge
    -> Identity (Graph ScopeID BasicBlock CFGEdge))
-> Maybe CFG
-> Identity (Maybe CFG)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph ScopeID BasicBlock CFGEdge
 -> Identity (Graph ScopeID BasicBlock CFGEdge))
-> CFG -> Identity CFG
#graph ((Graph ScopeID BasicBlock CFGEdge
  -> Identity (Graph ScopeID BasicBlock CFGEdge))
 -> CFGState -> Identity CFGState)
-> Graph ScopeID BasicBlock CFGEdge -> CFGBuild ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Graph ScopeID BasicBlock CFGEdge
g

updateCFG :: G.GraphBuilder BBID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG :: forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG GraphBuilder ScopeID BasicBlock CFGEdge a
update = do
  Graph ScopeID BasicBlock CFGEdge
g <- CFGBuild (Graph ScopeID BasicBlock CFGEdge)
getGraph
  let g' :: Either Name (Graph ScopeID BasicBlock CFGEdge)
g' = GraphBuilder ScopeID BasicBlock CFGEdge a
-> Graph ScopeID BasicBlock CFGEdge
-> Either Name (Graph ScopeID BasicBlock CFGEdge)
forall ni nd ed a.
(Eq ni, Ord ni) =>
GraphBuilder ni nd ed a
-> Graph ni nd ed -> Either Name (Graph ni nd ed)
G.update GraphBuilder ScopeID BasicBlock CFGEdge a
update Graph ScopeID BasicBlock CFGEdge
g
  case Either Name (Graph ScopeID BasicBlock CFGEdge)
g' of
    Left Name
m -> CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ()) -> CompileError -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing Name
m
    Right Graph ScopeID BasicBlock CFGEdge
g -> Graph ScopeID BasicBlock CFGEdge -> CFGBuild ()
setGraph Graph ScopeID BasicBlock CFGEdge
g

data CFGContext = CFGContext
  {CFGContext -> SemanticInfo
semantic :: SE.SemanticInfo}
  deriving ((forall x. CFGContext -> Rep CFGContext x)
-> (forall x. Rep CFGContext x -> CFGContext) -> Generic CFGContext
forall x. Rep CFGContext x -> CFGContext
forall x. CFGContext -> Rep CFGContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CFGContext -> Rep CFGContext x
from :: forall x. CFGContext -> Rep CFGContext x
$cto :: forall x. Rep CFGContext x -> CFGContext
to :: forall x. Rep CFGContext x -> CFGContext
Generic)

newtype CFGBuild a = CFGBuild
  { forall a.
CFGBuild a
-> ExceptT CompileError (ReaderT CFGContext (State CFGState)) a
runCFGBuild ::
      ExceptT
        CompileError
        (ReaderT CFGContext (State CFGState))
        a
  }
  deriving
    ( (forall a b. (a -> b) -> CFGBuild a -> CFGBuild b)
-> (forall a b. a -> CFGBuild b -> CFGBuild a) -> Functor CFGBuild
forall a b. a -> CFGBuild b -> CFGBuild a
forall a b. (a -> b) -> CFGBuild a -> CFGBuild b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CFGBuild a -> CFGBuild b
fmap :: forall a b. (a -> b) -> CFGBuild a -> CFGBuild b
$c<$ :: forall a b. a -> CFGBuild b -> CFGBuild a
<$ :: forall a b. a -> CFGBuild b -> CFGBuild a
Functor,
      Functor CFGBuild
Functor CFGBuild
-> (forall a. a -> CFGBuild a)
-> (forall a b. CFGBuild (a -> b) -> CFGBuild a -> CFGBuild b)
-> (forall a b c.
    (a -> b -> c) -> CFGBuild a -> CFGBuild b -> CFGBuild c)
-> (forall a b. CFGBuild a -> CFGBuild b -> CFGBuild b)
-> (forall a b. CFGBuild a -> CFGBuild b -> CFGBuild a)
-> Applicative CFGBuild
forall a. a -> CFGBuild a
forall a b. CFGBuild a -> CFGBuild b -> CFGBuild a
forall a b. CFGBuild a -> CFGBuild b -> CFGBuild b
forall a b. CFGBuild (a -> b) -> CFGBuild a -> CFGBuild b
forall a b c.
(a -> b -> c) -> CFGBuild a -> CFGBuild b -> CFGBuild c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> CFGBuild a
pure :: forall a. a -> CFGBuild a
$c<*> :: forall a b. CFGBuild (a -> b) -> CFGBuild a -> CFGBuild b
<*> :: forall a b. CFGBuild (a -> b) -> CFGBuild a -> CFGBuild b
$cliftA2 :: forall a b c.
(a -> b -> c) -> CFGBuild a -> CFGBuild b -> CFGBuild c
liftA2 :: forall a b c.
(a -> b -> c) -> CFGBuild a -> CFGBuild b -> CFGBuild c
$c*> :: forall a b. CFGBuild a -> CFGBuild b -> CFGBuild b
*> :: forall a b. CFGBuild a -> CFGBuild b -> CFGBuild b
$c<* :: forall a b. CFGBuild a -> CFGBuild b -> CFGBuild a
<* :: forall a b. CFGBuild a -> CFGBuild b -> CFGBuild a
Applicative,
      Applicative CFGBuild
Applicative CFGBuild
-> (forall a b. CFGBuild a -> (a -> CFGBuild b) -> CFGBuild b)
-> (forall a b. CFGBuild a -> CFGBuild b -> CFGBuild b)
-> (forall a. a -> CFGBuild a)
-> Monad CFGBuild
forall a. a -> CFGBuild a
forall a b. CFGBuild a -> CFGBuild b -> CFGBuild b
forall a b. CFGBuild a -> (a -> CFGBuild b) -> CFGBuild b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. CFGBuild a -> (a -> CFGBuild b) -> CFGBuild b
>>= :: forall a b. CFGBuild a -> (a -> CFGBuild b) -> CFGBuild b
$c>> :: forall a b. CFGBuild a -> CFGBuild b -> CFGBuild b
>> :: forall a b. CFGBuild a -> CFGBuild b -> CFGBuild b
$creturn :: forall a. a -> CFGBuild a
return :: forall a. a -> CFGBuild a
Monad,
      MonadError CompileError,
      MonadReader CFGContext,
      MonadState CFGState
    )

setASTScope :: ScopeID -> CFGBuild ()
setASTScope :: ScopeID -> CFGBuild ()
setASTScope ScopeID
sid = do
  #astScope .= sid

{-----------------------------------------------------------
  Record current innermost control block (while/for/etc.)
  for continue/break to find correct successor block.
------------------------------------------------------------}
setControlBlock :: Maybe (BBID, BBID) -> CFGBuild ()
setControlBlock :: Maybe (ScopeID, ScopeID) -> CFGBuild ()
setControlBlock Maybe (ScopeID, ScopeID)
entryAndExit = do
  #currentControlBlock .= entryAndExit

getControlBlock :: CFGBuild (Maybe (BBID, BBID))
getControlBlock :: CFGBuild (Maybe (ScopeID, ScopeID))
getControlBlock = Getting
  (Maybe (ScopeID, ScopeID)) CFGState (Maybe (ScopeID, ScopeID))
-> CFGBuild (Maybe (ScopeID, ScopeID))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Maybe (ScopeID, ScopeID)) CFGState (Maybe (ScopeID, ScopeID))
#currentControlBlock

getControlEntry :: CFGBuild (Maybe BBID)
getControlEntry :: CFGBuild (Maybe ScopeID)
getControlEntry = Getting
  (Maybe (ScopeID, ScopeID)) CFGState (Maybe (ScopeID, ScopeID))
-> CFGBuild (Maybe (ScopeID, ScopeID))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Maybe (ScopeID, ScopeID)) CFGState (Maybe (ScopeID, ScopeID))
#currentControlBlock CFGBuild (Maybe (ScopeID, ScopeID))
-> (Maybe (ScopeID, ScopeID) -> Maybe ScopeID)
-> CFGBuild (Maybe ScopeID)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe (ScopeID, ScopeID)
-> ((ScopeID, ScopeID) -> ScopeID) -> Maybe ScopeID
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((ScopeID, ScopeID)
-> Getting ScopeID (ScopeID, ScopeID) ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID (ScopeID, ScopeID) ScopeID
forall s t a b. Field1 s t a b => Lens s t a b
Lens (ScopeID, ScopeID) (ScopeID, ScopeID) ScopeID ScopeID
_1))

getControlExit :: CFGBuild (Maybe BBID)
getControlExit :: CFGBuild (Maybe ScopeID)
getControlExit = Getting
  (Maybe (ScopeID, ScopeID)) CFGState (Maybe (ScopeID, ScopeID))
-> CFGBuild (Maybe (ScopeID, ScopeID))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Maybe (ScopeID, ScopeID)) CFGState (Maybe (ScopeID, ScopeID))
#currentControlBlock CFGBuild (Maybe (ScopeID, ScopeID))
-> (Maybe (ScopeID, ScopeID) -> Maybe ScopeID)
-> CFGBuild (Maybe ScopeID)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe (ScopeID, ScopeID)
-> ((ScopeID, ScopeID) -> ScopeID) -> Maybe ScopeID
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((ScopeID, ScopeID)
-> Getting ScopeID (ScopeID, ScopeID) ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID (ScopeID, ScopeID) ScopeID
forall s t a b. Field2 s t a b => Lens s t a b
Lens (ScopeID, ScopeID) (ScopeID, ScopeID) ScopeID ScopeID
_2))

withControlBlock :: BBID -> BBID -> CFGBuild a -> CFGBuild a
withControlBlock :: forall a. ScopeID -> ScopeID -> CFGBuild a -> CFGBuild a
withControlBlock ScopeID
entry ScopeID
exit CFGBuild a
f = do
  Maybe (ScopeID, ScopeID)
prevCB <- CFGBuild (Maybe (ScopeID, ScopeID))
getControlBlock
  Maybe (ScopeID, ScopeID) -> CFGBuild ()
setControlBlock (Maybe (ScopeID, ScopeID) -> CFGBuild ())
-> Maybe (ScopeID, ScopeID) -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ (ScopeID, ScopeID) -> Maybe (ScopeID, ScopeID)
forall a. a -> Maybe a
Just (ScopeID
entry, ScopeID
exit)
  a
res <- CFGBuild a
f
  Maybe (ScopeID, ScopeID) -> CFGBuild ()
setControlBlock Maybe (ScopeID, ScopeID)
prevCB
  a -> CFGBuild a
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

{-----------------------------------------------------------
  Record function tail for return to find correct
  successor block.
------------------------------------------------------------}

setFunctionEntry :: BBID -> CFGBuild ()
setFunctionEntry :: ScopeID -> CFGBuild ()
setFunctionEntry ScopeID
entry = do
  #cfg . _Just . #entry .= entry

setFunctionExit :: BBID -> CFGBuild ()
setFunctionExit :: ScopeID -> CFGBuild ()
setFunctionExit ScopeID
exit = do
  #cfg . _Just . #exit .= exit

getFunctionExit :: CFGBuild BBID
getFunctionExit :: CFGBuild ScopeID
getFunctionExit = CFGBuild CFG
getCFG CFGBuild CFG -> (CFG -> ScopeID) -> CFGBuild ScopeID
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Getting ScopeID CFG ScopeID -> CFG -> ScopeID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ScopeID CFG ScopeID
#exit

getBasicBlock' :: BBID -> CFGBuild BasicBlock
getBasicBlock' :: ScopeID -> CFGBuild BasicBlock
getBasicBlock' ScopeID
bbid = do
  Graph ScopeID BasicBlock CFGEdge
g <- CFGBuild (Graph ScopeID BasicBlock CFGEdge)
getGraph
  case ScopeID -> Graph ScopeID BasicBlock CFGEdge -> Maybe BasicBlock
forall ni nd ed.
(Eq ni, Ord ni) =>
ni -> Graph ni nd ed -> Maybe nd
G.lookupNode ScopeID
bbid Graph ScopeID BasicBlock CFGEdge
g of
    Maybe BasicBlock
Nothing -> CompileError -> CFGBuild BasicBlock
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild BasicBlock)
-> CompileError -> CFGBuild BasicBlock
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"Unable to find basic block" Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) ScopeID
bbid
    Just BasicBlock
node -> BasicBlock -> CFGBuild BasicBlock
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return BasicBlock
node

{-----------------------------------------------------------
Add/lookup symbols or variables
------------------------------------------------------------}
addVarSym :: Name -> VID -> CFGBuild ()
addVarSym :: Name -> ScopeID -> CFGBuild ()
addVarSym Name
name ScopeID
vid = do
  ScopeID
sid <-
    Name -> CFGBuild (Maybe ScopeID)
getSymScope Name
name CFGBuild (Maybe ScopeID)
-> (Maybe ScopeID -> CFGBuild ScopeID) -> CFGBuild ScopeID
forall a b. CFGBuild a -> (a -> CFGBuild b) -> CFGBuild b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe ScopeID
Nothing -> CompileError -> CFGBuild ScopeID
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ScopeID)
-> CompileError -> CFGBuild ScopeID
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Unable to find symbol" Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
name
      Just ScopeID
sid -> ScopeID -> CFGBuild ScopeID
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ScopeID
sid
  -- update var->sym
  #var2sym %= Map.insert vid (sid, name)
  -- update sym->var
  Map ScopeID SymVarMap
sym2var <- Getting (Map ScopeID SymVarMap) CFGState (Map ScopeID SymVarMap)
-> CFGBuild (Map ScopeID SymVarMap)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Map ScopeID SymVarMap) CFGState (Map ScopeID SymVarMap)
#sym2var
  let sym2varInScope :: Maybe SymVarMap
sym2varInScope = ScopeID -> Map ScopeID SymVarMap -> Maybe SymVarMap
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
sid Map ScopeID SymVarMap
sym2var
  case Maybe SymVarMap
sym2varInScope of
    Maybe SymVarMap
Nothing -> CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ()) -> CompileError -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"Unable to find scope" Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int Format Name (ScopeID -> Name)
-> Format Name Name -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name Name
"in sym->var map") ScopeID
sid
    Just SymVarMap
s2v -> ASetter
  CFGState CFGState (Map ScopeID SymVarMap) (Map ScopeID SymVarMap)
#sym2var ASetter
  CFGState CFGState (Map ScopeID SymVarMap) (Map ScopeID SymVarMap)
-> (Map ScopeID SymVarMap -> Map ScopeID SymVarMap) -> CFGBuild ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ScopeID
-> SymVarMap -> Map ScopeID SymVarMap -> Map ScopeID SymVarMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopeID
sid (SymVarMap
s2v SymVarMap -> (SymVarMap -> SymVarMap) -> SymVarMap
forall a b. a -> (a -> b) -> b
& ASetter SymVarMap SymVarMap (Map Name ScopeID) (Map Name ScopeID)
#m ASetter SymVarMap SymVarMap (Map Name ScopeID) (Map Name ScopeID)
-> (Map Name ScopeID -> Map Name ScopeID) -> SymVarMap -> SymVarMap
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Name -> ScopeID -> Map Name ScopeID -> Map Name ScopeID
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name ScopeID
vid)

lookupVar :: VID -> CFGBuild (Maybe (ScopeID, Name))
lookupVar :: ScopeID -> CFGBuild (Maybe (ScopeID, Name))
lookupVar ScopeID
vid = LensLike'
  (Const (Maybe (ScopeID, Name)))
  CFGState
  (Map ScopeID (ScopeID, Name))
-> (Map ScopeID (ScopeID, Name) -> Maybe (ScopeID, Name))
-> CFGBuild (Maybe (ScopeID, Name))
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike'
  (Const (Maybe (ScopeID, Name)))
  CFGState
  (Map ScopeID (ScopeID, Name))
#var2sym ((Map ScopeID (ScopeID, Name) -> Maybe (ScopeID, Name))
 -> CFGBuild (Maybe (ScopeID, Name)))
-> (Map ScopeID (ScopeID, Name) -> Maybe (ScopeID, Name))
-> CFGBuild (Maybe (ScopeID, Name))
forall a b. (a -> b) -> a -> b
$ ScopeID -> Map ScopeID (ScopeID, Name) -> Maybe (ScopeID, Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
vid

lookupVar' :: VID -> CFGBuild (ScopeID, Name)
lookupVar' :: ScopeID -> CFGBuild (ScopeID, Name)
lookupVar' ScopeID
vid =
  ScopeID -> CFGBuild (Maybe (ScopeID, Name))
lookupVar ScopeID
vid CFGBuild (Maybe (ScopeID, Name))
-> (Maybe (ScopeID, Name) -> CFGBuild (ScopeID, Name))
-> CFGBuild (ScopeID, Name)
forall a b. CFGBuild a -> (a -> CFGBuild b) -> CFGBuild b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ScopeID, Name)
Nothing -> CompileError -> CFGBuild (ScopeID, Name)
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild (ScopeID, Name))
-> CompileError -> CFGBuild (ScopeID, Name)
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"Unable to find variable" Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) ScopeID
vid
    Just (ScopeID, Name)
res -> (ScopeID, Name) -> CFGBuild (ScopeID, Name)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopeID, Name)
res

-- Look for symbol resursively
lookupSymInScope :: Name -> ScopeID -> CFGBuild (Maybe Var)
lookupSymInScope :: Name -> ScopeID -> CFGBuild (Maybe Var)
lookupSymInScope Name
name ScopeID
sid = do
  Map ScopeID SymVarMap
sym2var <- Getting (Map ScopeID SymVarMap) CFGState (Map ScopeID SymVarMap)
-> CFGBuild (Map ScopeID SymVarMap)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Map ScopeID SymVarMap) CFGState (Map ScopeID SymVarMap)
#sym2var
  [Var]
vars <- Getting [Var] CFGState [Var] -> CFGBuild [Var]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [Var] CFGState [Var]
#vars
  let vid :: Maybe ScopeID
vid = ScopeID -> Map ScopeID SymVarMap -> Maybe SymVarMap
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
sid Map ScopeID SymVarMap
sym2var Maybe SymVarMap -> (SymVarMap -> Maybe ScopeID) -> Maybe ScopeID
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\SymVarMap
m' -> Name -> SymVarMap -> Map ScopeID SymVarMap -> Maybe ScopeID
lookup Name
name SymVarMap
m' Map ScopeID SymVarMap
sym2var)
  Maybe Var -> CFGBuild (Maybe Var)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Var -> CFGBuild (Maybe Var))
-> Maybe Var -> CFGBuild (Maybe Var)
forall a b. (a -> b) -> a -> b
$ Maybe ScopeID
vid Maybe ScopeID -> (ScopeID -> Var) -> Maybe Var
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Var]
vars [Var] -> ScopeID -> Var
forall a. HasCallStack => [a] -> ScopeID -> a
!!)
  where
    lookup :: Name -> SymVarMap -> Map ScopeID SymVarMap -> Maybe VID
    lookup :: Name -> SymVarMap -> Map ScopeID SymVarMap -> Maybe ScopeID
lookup Name
name SymVarMap
symVarMap Map ScopeID SymVarMap
sym2var = case Name -> Map Name ScopeID -> Maybe ScopeID
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (SymVarMap
symVarMap SymVarMap
-> Getting (Map Name ScopeID) SymVarMap (Map Name ScopeID)
-> Map Name ScopeID
forall s a. s -> Getting a s a -> a
^. Getting (Map Name ScopeID) SymVarMap (Map Name ScopeID)
#m) of
      Just ScopeID
vid -> ScopeID -> Maybe ScopeID
forall a. a -> Maybe a
Just ScopeID
vid
      Maybe ScopeID
Nothing ->
        (SymVarMap
symVarMap SymVarMap
-> Getting (Maybe ScopeID) SymVarMap (Maybe ScopeID)
-> Maybe ScopeID
forall s a. s -> Getting a s a -> a
^. Getting (Maybe ScopeID) SymVarMap (Maybe ScopeID)
#parent)
          Maybe ScopeID -> (ScopeID -> Maybe SymVarMap) -> Maybe SymVarMap
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ScopeID -> Map ScopeID SymVarMap -> Maybe SymVarMap
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ScopeID SymVarMap
sym2var)
          Maybe SymVarMap -> (SymVarMap -> Maybe ScopeID) -> Maybe ScopeID
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SymVarMap
map' -> Name -> SymVarMap -> Map ScopeID SymVarMap -> Maybe ScopeID
lookup Name
name SymVarMap
map' Map ScopeID SymVarMap
sym2var

lookupSymInScope' :: Name -> ScopeID -> CFGBuild Var
lookupSymInScope' :: Name -> ScopeID -> CFGBuild Var
lookupSymInScope' Name
name ScopeID
sid = do
  Maybe Var
var' <- Name -> ScopeID -> CFGBuild (Maybe Var)
lookupSymInScope Name
name ScopeID
sid
  case Maybe Var
var' of
    Maybe Var
Nothing -> CompileError -> CFGBuild Var
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild Var) -> CompileError -> CFGBuild Var
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> ScopeID -> Name) -> Name -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (Name -> ScopeID -> Name) (Name -> ScopeID -> Name)
"Unable to find symbol" Format (Name -> ScopeID -> Name) (Name -> ScopeID -> Name)
-> Format Name (Name -> ScopeID -> Name)
-> Format Name (Name -> ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (ScopeID -> Name) (Name -> ScopeID -> Name)
forall r. Format r (Name -> r)
stext Format (ScopeID -> Name) (Name -> ScopeID -> Name)
-> Format Name (ScopeID -> Name)
-> Format Name (Name -> ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (ScopeID -> Name) (ScopeID -> Name)
"in scope" Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) Name
name ScopeID
sid
    Just Var
var -> Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
var

lookupSym :: Name -> CFGBuild (Maybe Var)
lookupSym :: Name -> CFGBuild (Maybe Var)
lookupSym Name
name = do
  ScopeID
sid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  Name -> ScopeID -> CFGBuild (Maybe Var)
lookupSymInScope Name
name ScopeID
sid

lookupSym' :: Name -> CFGBuild Var
lookupSym' :: Name -> CFGBuild Var
lookupSym' Name
name = do
  ScopeID
sid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  Name -> ScopeID -> CFGBuild Var
lookupSymInScope' Name
name ScopeID
sid

getSymDecl :: Name -> CFGBuild (Maybe (Either AST.Argument AST.FieldDecl))
getSymDecl :: Name -> CFGBuild (Maybe (Either Argument FieldDecl))
getSymDecl Name
name = do
  ScopeID
sid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  Map ScopeID SymbolTable
sts <- Getting
  (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
-> CFGBuild (Map ScopeID SymbolTable)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
 -> CFGBuild (Map ScopeID SymbolTable))
-> Getting
     (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
-> CFGBuild (Map ScopeID SymbolTable)
forall a b. (a -> b) -> a -> b
$ (SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
-> CFGContext -> Const (Map ScopeID SymbolTable) CFGContext
#semantic ((SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
 -> CFGContext -> Const (Map ScopeID SymbolTable) CFGContext)
-> ((Map ScopeID SymbolTable
     -> Const (Map ScopeID SymbolTable) (Map ScopeID SymbolTable))
    -> SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
-> Getting
     (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScopeID SymbolTable
 -> Const (Map ScopeID SymbolTable) (Map ScopeID SymbolTable))
-> SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo
#symbolTables
  case ScopeID -> Map ScopeID SymbolTable -> Maybe SymbolTable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
sid Map ScopeID SymbolTable
sts of
    Maybe SymbolTable
Nothing -> CompileError -> CFGBuild (Maybe (Either Argument FieldDecl))
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild (Maybe (Either Argument FieldDecl)))
-> CompileError -> CFGBuild (Maybe (Either Argument FieldDecl))
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"Unable to find scope " Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) ScopeID
sid)
    Just SymbolTable
st -> Maybe (Either Argument FieldDecl)
-> CFGBuild (Maybe (Either Argument FieldDecl))
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Argument FieldDecl)
 -> CFGBuild (Maybe (Either Argument FieldDecl)))
-> Maybe (Either Argument FieldDecl)
-> CFGBuild (Maybe (Either Argument FieldDecl))
forall a b. (a -> b) -> a -> b
$ Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookup Name
name SymbolTable
st
  where
    lookup :: Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookup Name
name SymbolTable
st' =
      (Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
SE.lookupLocalVariableFromST Name
name SymbolTable
st')
        Maybe (Either Argument FieldDecl)
-> Maybe (Either Argument FieldDecl)
-> Maybe (Either Argument FieldDecl)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SymbolTable -> Maybe SymbolTable
SE.parent SymbolTable
st' Maybe SymbolTable
-> (SymbolTable -> Maybe (Either Argument FieldDecl))
-> Maybe (Either Argument FieldDecl)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookup Name
name)

getSymScope :: Name -> CFGBuild (Maybe ScopeID)
getSymScope :: Name -> CFGBuild (Maybe ScopeID)
getSymScope Name
name = do
  ScopeID
sid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  Map ScopeID SymbolTable
sts <- Getting
  (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
-> CFGBuild (Map ScopeID SymbolTable)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
 -> CFGBuild (Map ScopeID SymbolTable))
-> Getting
     (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
-> CFGBuild (Map ScopeID SymbolTable)
forall a b. (a -> b) -> a -> b
$ (SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
-> CFGContext -> Const (Map ScopeID SymbolTable) CFGContext
#semantic ((SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
 -> CFGContext -> Const (Map ScopeID SymbolTable) CFGContext)
-> ((Map ScopeID SymbolTable
     -> Const (Map ScopeID SymbolTable) (Map ScopeID SymbolTable))
    -> SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
-> Getting
     (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScopeID SymbolTable
 -> Const (Map ScopeID SymbolTable) (Map ScopeID SymbolTable))
-> SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo
#symbolTables
  case ScopeID -> Map ScopeID SymbolTable -> Maybe SymbolTable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
sid Map ScopeID SymbolTable
sts of
    Maybe SymbolTable
Nothing -> CompileError -> CFGBuild (Maybe ScopeID)
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild (Maybe ScopeID))
-> CompileError -> CFGBuild (Maybe ScopeID)
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"Unable to find scope " Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) ScopeID
sid)
    Just SymbolTable
st -> Maybe ScopeID -> CFGBuild (Maybe ScopeID)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ScopeID -> CFGBuild (Maybe ScopeID))
-> Maybe ScopeID -> CFGBuild (Maybe ScopeID)
forall a b. (a -> b) -> a -> b
$ Name -> SymbolTable -> Maybe ScopeID
lookup Name
name SymbolTable
st
  where
    lookup :: Name -> SymbolTable -> Maybe ScopeID
lookup Name
name SymbolTable
st' =
      (Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
SE.lookupLocalVariableFromST Name
name SymbolTable
st' Maybe (Either Argument FieldDecl)
-> (Either Argument FieldDecl -> ScopeID) -> Maybe ScopeID
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Either Argument FieldDecl
_ -> Getting ScopeID SymbolTable ScopeID -> SymbolTable -> ScopeID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ScopeID SymbolTable ScopeID
#scopeID SymbolTable
st')
        Maybe ScopeID -> Maybe ScopeID -> Maybe ScopeID
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SymbolTable -> Maybe SymbolTable
SE.parent SymbolTable
st' Maybe SymbolTable
-> (SymbolTable -> Maybe ScopeID) -> Maybe ScopeID
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> SymbolTable -> Maybe ScopeID
lookup Name
name)

newVar :: Maybe Name -> AST.Type -> SL.Range -> Locality -> CFGBuild Var
newVar :: Maybe Name -> Type -> Range -> Locality -> CFGBuild Var
newVar Maybe Name
Nothing Type
tpe Range
sl Locality
locality = do
  [Var]
vars <- Getting [Var] CFGState [Var] -> CFGBuild [Var]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [Var] CFGState [Var]
#vars
  let vid :: ScopeID
vid = [Var] -> ScopeID
forall a. [a] -> ScopeID
forall (t :: * -> *) a. Foldable t => t a -> ScopeID
length [Var]
vars
  let var :: Var
var = ScopeID
-> Type
-> Maybe (Either Argument FieldDecl)
-> Range
-> Locality
-> Var
Var ScopeID
vid Type
tpe Maybe (Either Argument FieldDecl)
forall a. Maybe a
Nothing Range
sl Locality
locality
  #vars .= vars ++ [var]
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
var
newVar (Just Name
name) Type
tpe Range
sl Locality
locality = do
  [Var]
vars <- Getting [Var] CFGState [Var] -> CFGBuild [Var]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [Var] CFGState [Var]
#vars
  let vid :: ScopeID
vid = [Var] -> ScopeID
forall a. [a] -> ScopeID
forall (t :: * -> *) a. Foldable t => t a -> ScopeID
length [Var]
vars
  Maybe (Either Argument FieldDecl)
decl <- Name -> CFGBuild (Maybe (Either Argument FieldDecl))
getSymDecl Name
name
  Bool -> CFGBuild () -> CFGBuild ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Either Argument FieldDecl) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Either Argument FieldDecl)
decl) (CFGBuild () -> CFGBuild ()) -> CFGBuild () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
sl) (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Unable to find decl of variable " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
name)
  let var :: Var
var = ScopeID
-> Type
-> Maybe (Either Argument FieldDecl)
-> Range
-> Locality
-> Var
Var ScopeID
vid Type
tpe Maybe (Either Argument FieldDecl)
decl Range
sl Locality
locality
  #vars .= vars ++ [var]
  Name -> ScopeID -> CFGBuild ()
addVarSym Name
name ScopeID
vid
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
var

newLocal :: Maybe Name -> AST.Type -> SL.Range -> CFGBuild Var
newLocal :: Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
name tpe :: Type
tpe@(AST.ArrayType Type
_ Int64
_) Range
sl =
  CompileError -> CFGBuild Var
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
sl) (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (Maybe Name -> Name) -> Maybe Name -> Name
forall a. Format Name a -> a
sformat (Format (Maybe Name -> Name) (Maybe Name -> Name)
"Trying to create reg for an array: " Format (Maybe Name -> Name) (Maybe Name -> Name)
-> Format Name (Maybe Name -> Name)
-> Format Name (Maybe Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Maybe Name -> Name)
forall a r. Show a => Format r (a -> r)
shown) Maybe Name
name)
newLocal Maybe Name
name Type
tpe Range
sl = Maybe Name -> Type -> Range -> Locality -> CFGBuild Var
newVar Maybe Name
name Type
tpe Range
sl Locality
Local

allocaOnStack :: Maybe Name -> AST.Type -> SL.Range -> CFGBuild Var
allocaOnStack :: Maybe Name -> Type -> Range -> CFGBuild Var
allocaOnStack Maybe Name
name tpe' :: Type
tpe'@(AST.ArrayType Type
tpe Int64
sz) Range
sl = do
  Var
ptr <- Maybe Name -> Type -> Range -> Locality -> CFGBuild Var
newVar Maybe Name
name Type
tpe' Range
sl Locality
Local
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Maybe Int64 -> SSA
Alloca Var
ptr Type
tpe (Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
sz)
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
ptr
allocaOnStack Maybe Name
name Type
tpe Range
sl = do
  Var
ptr <- Maybe Name -> Type -> Range -> Locality -> CFGBuild Var
newVar Maybe Name
name (Type -> Type
AST.Ptr Type
tpe) Range
sl Locality
Local
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> Type -> Maybe Int64 -> SSA
Alloca Var
ptr Type
tpe Maybe Int64
forall a. Maybe a
Nothing
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
ptr

newGlobal :: Name -> AST.Type -> SL.Range -> CFGBuild Var
newGlobal :: Name -> Type -> Range -> CFGBuild Var
newGlobal Name
name tpe :: Type
tpe@(AST.ArrayType Type
_ Int64
_) Range
sl = do
  ScopeID
sid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  ScopeID -> CFGBuild ()
setASTScope ScopeID
0
  Var
ptr <- Maybe Name -> Type -> Range -> Locality -> CFGBuild Var
newVar (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) Type
tpe Range
sl Locality
Global
  ScopeID -> CFGBuild ()
setASTScope ScopeID
sid
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
ptr
newGlobal Name
name Type
tpe Range
sl = do
  ScopeID
sid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  ScopeID -> CFGBuild ()
setASTScope ScopeID
0
  Var
ptr <- Maybe Name -> Type -> Range -> Locality -> CFGBuild Var
newVar (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) (Type -> Type
AST.Ptr Type
tpe) Range
sl Locality
Global
  ScopeID -> CFGBuild ()
setASTScope ScopeID
sid
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
ptr

{-----------------------------------------------------------
Basic block manipulations
------------------------------------------------------------}

createEmptyBB :: CFGBuild BBID
createEmptyBB :: CFGBuild ScopeID
createEmptyBB = do
  CFGBuild ()
checkStmts
  #currentBBID += 1
  ScopeID
bbid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  ScopeID
sid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  let bb :: BasicBlock
bb = ScopeID -> ScopeID -> [SSA] -> BasicBlock
BasicBlock ScopeID
bbid ScopeID
sid []
  GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (ScopeID -> BasicBlock -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni nd ed.
(Eq ni, Ord ni) =>
ni -> nd -> GraphBuilder ni nd ed ()
G.addNode ScopeID
bbid BasicBlock
bb)
  ScopeID -> CFGBuild ScopeID
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ScopeID
bbid

createBB :: [SSA] -> CFGBuild BBID
createBB :: [SSA] -> CFGBuild ScopeID
createBB [SSA]
stmts = do
  #currentBBID += 1
  bbid <- use #currentBBID
  sid <- use #astScope
  let bb = BasicBlock bbid sid stmts
  updateCFG (G.addNode bbid bb)
  return bbid

finishCurrentBB :: CFGBuild BBID
finishCurrentBB :: CFGBuild ScopeID
finishCurrentBB = do
  ScopeID
bbid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  [SSA]
stmts <- Getting [SSA] CFGState [SSA] -> CFGBuild [SSA]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [SSA] CFGState [SSA]
#statements
  ScopeID
sid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  #statements .= []
  let bb :: BasicBlock
bb = ScopeID -> ScopeID -> [SSA] -> BasicBlock
BasicBlock ScopeID
bbid ScopeID
sid [SSA]
stmts
  GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (ScopeID -> BasicBlock -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni nd ed.
(Eq ni, Ord ni) =>
ni -> nd -> GraphBuilder ni nd ed ()
G.addNode ScopeID
bbid BasicBlock
bb)
  #currentBBID += 1
  ScopeID -> CFGBuild ScopeID
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ScopeID
bbid

checkStmts :: CFGBuild ()
checkStmts :: CFGBuild ()
checkStmts = do
  [SSA]
stmts <- Getting [SSA] CFGState [SSA] -> CFGBuild [SSA]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [SSA] CFGState [SSA]
#statements
  Bool -> CFGBuild () -> CFGBuild ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SSA] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SSA]
stmts) (CFGBuild () -> CFGBuild ()) -> CFGBuild () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ()) -> CompileError -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
Text.pack ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"Dangling statements found: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [SSA] -> [Char]
forall a. Show a => a -> [Char]
show [SSA]
stmts

addSSA :: SSA -> CFGBuild ()
addSSA :: SSA -> CFGBuild ()
addSSA SSA
ssa = do
  [SSA]
stmts <- Getting [SSA] CFGState [SSA] -> CFGBuild [SSA]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [SSA] CFGState [SSA]
#statements
  #statements .= stmts ++ [ssa]

{-----------------------------------------------------------
Functionalities to help adding phi nodes.

We do this in 4 steps:
1. Decide which symbols are required to be handled by phi nodes with inferPhiList.
   This relies on symbol modification information gathered in semantic analysis
   pass. Due to backward edges introduced by loops this information is
   not very convinient to get in the current module unless we add another pass.
2. Add dummy phi nodes at the start of control flow merging points.
3. For each symbol gathered in step 1, record which SSA var corresponds to it
   at the end each diverging control flow. The order of step 2 and 3 depends on
   the type of control flow we are dealing with.
4. Patch SSA var and its source basic block (from step 3) into dummy phi nodes
   added by step 2.
------------------------------------------------------------}

findOuterScopes :: CFGBuild (Set ScopeID)
findOuterScopes :: CFGBuild (Set ScopeID)
findOuterScopes = do
  -- Set.fromList $ lookup scope sts
  ScopeID
scope <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  Map ScopeID SymbolTable
sts <- Getting
  (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
-> CFGBuild (Map ScopeID SymbolTable)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
-> CFGContext -> Const (Map ScopeID SymbolTable) CFGContext
#semantic ((SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
 -> CFGContext -> Const (Map ScopeID SymbolTable) CFGContext)
-> ((Map ScopeID SymbolTable
     -> Const (Map ScopeID SymbolTable) (Map ScopeID SymbolTable))
    -> SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
-> Getting
     (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScopeID SymbolTable
 -> Const (Map ScopeID SymbolTable) (Map ScopeID SymbolTable))
-> SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo
#symbolTables)
  Set ScopeID -> CFGBuild (Set ScopeID)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set ScopeID -> CFGBuild (Set ScopeID))
-> Set ScopeID -> CFGBuild (Set ScopeID)
forall a b. (a -> b) -> a -> b
$ [ScopeID] -> Set ScopeID
forall a. Ord a => [a] -> Set a
Set.fromList ([ScopeID] -> Set ScopeID) -> [ScopeID] -> Set ScopeID
forall a b. (a -> b) -> a -> b
$ ScopeID -> Map ScopeID SymbolTable -> [ScopeID]
lookup ScopeID
scope Map ScopeID SymbolTable
sts
  where
    lookup :: ScopeID -> Map ScopeID SE.SymbolTable -> [ScopeID]
    lookup :: ScopeID -> Map ScopeID SymbolTable -> [ScopeID]
lookup ScopeID
scope Map ScopeID SymbolTable
sts =
      case ScopeID -> Map ScopeID SymbolTable -> Maybe SymbolTable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
scope Map ScopeID SymbolTable
sts of
        Maybe SymbolTable
Nothing -> []
        Just SymbolTable
st -> case Getting (Maybe SymbolTable) SymbolTable (Maybe SymbolTable)
-> SymbolTable -> Maybe SymbolTable
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe SymbolTable) SymbolTable (Maybe SymbolTable)
#parent SymbolTable
st of
          Maybe SymbolTable
Nothing -> [ScopeID
scope]
          Just SymbolTable
parent ->
            let parentSID :: ScopeID
parentSID = Getting ScopeID SymbolTable ScopeID -> SymbolTable -> ScopeID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ScopeID SymbolTable ScopeID
#scopeID SymbolTable
parent
             in ScopeID
scope ScopeID -> [ScopeID] -> [ScopeID]
forall a. a -> [a] -> [a]
: ScopeID -> Map ScopeID SymbolTable -> [ScopeID]
lookup ScopeID
parentSID Map ScopeID SymbolTable
sts

inferPhiList :: [ScopeID] -> CFGBuild [(ScopeID, Name)]
inferPhiList :: [ScopeID] -> CFGBuild [(ScopeID, Name)]
inferPhiList [ScopeID]
divergence = do
  Set ScopeID
outerScopes <- CFGBuild (Set ScopeID)
findOuterScopes
  Map ScopeID (Set (ScopeID, Name))
varWrites <- Getting
  (Map ScopeID (Set (ScopeID, Name)))
  CFGContext
  (Map ScopeID (Set (ScopeID, Name)))
-> CFGBuild (Map ScopeID (Set (ScopeID, Name)))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map ScopeID (Set (ScopeID, Name)))
   CFGContext
   (Map ScopeID (Set (ScopeID, Name)))
 -> CFGBuild (Map ScopeID (Set (ScopeID, Name))))
-> Getting
     (Map ScopeID (Set (ScopeID, Name)))
     CFGContext
     (Map ScopeID (Set (ScopeID, Name)))
-> CFGBuild (Map ScopeID (Set (ScopeID, Name)))
forall a b. (a -> b) -> a -> b
$ (SemanticInfo
 -> Const (Map ScopeID (Set (ScopeID, Name))) SemanticInfo)
-> CFGContext
-> Const (Map ScopeID (Set (ScopeID, Name))) CFGContext
#semantic ((SemanticInfo
  -> Const (Map ScopeID (Set (ScopeID, Name))) SemanticInfo)
 -> CFGContext
 -> Const (Map ScopeID (Set (ScopeID, Name))) CFGContext)
-> ((Map ScopeID (Set (ScopeID, Name))
     -> Const
          (Map ScopeID (Set (ScopeID, Name)))
          (Map ScopeID (Set (ScopeID, Name))))
    -> SemanticInfo
    -> Const (Map ScopeID (Set (ScopeID, Name))) SemanticInfo)
-> Getting
     (Map ScopeID (Set (ScopeID, Name)))
     CFGContext
     (Map ScopeID (Set (ScopeID, Name)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScopeID (Set (ScopeID, Name))
 -> Const
      (Map ScopeID (Set (ScopeID, Name)))
      (Map ScopeID (Set (ScopeID, Name))))
-> SemanticInfo
-> Const (Map ScopeID (Set (ScopeID, Name))) SemanticInfo
#symbolWrites
  let varList :: [(ScopeID, Name)]
varList =
        ((ScopeID, Name) -> Bool) -> [(ScopeID, Name)] -> [(ScopeID, Name)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ScopeID
sid, Name
_) -> ScopeID -> Set ScopeID -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ScopeID
sid Set ScopeID
outerScopes) ([(ScopeID, Name)] -> [(ScopeID, Name)])
-> [(ScopeID, Name)] -> [(ScopeID, Name)]
forall a b. (a -> b) -> a -> b
$
          Set (ScopeID, Name) -> [(ScopeID, Name)]
forall a. Set a -> [a]
Set.toList (Set (ScopeID, Name) -> [(ScopeID, Name)])
-> Set (ScopeID, Name) -> [(ScopeID, Name)]
forall a b. (a -> b) -> a -> b
$
            [Set (ScopeID, Name)] -> Set (ScopeID, Name)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set (ScopeID, Name)] -> Set (ScopeID, Name))
-> [Set (ScopeID, Name)] -> Set (ScopeID, Name)
forall a b. (a -> b) -> a -> b
$
              (ScopeID -> Maybe (Set (ScopeID, Name)))
-> [ScopeID] -> [Set (ScopeID, Name)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ScopeID
-> Map ScopeID (Set (ScopeID, Name)) -> Maybe (Set (ScopeID, Name))
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ScopeID (Set (ScopeID, Name))
varWrites) [ScopeID]
divergence
  [(ScopeID, Name)] -> CFGBuild [(ScopeID, Name)]
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return [(ScopeID, Name)]
varList

addDummyPhiNode :: [(ScopeID, Name)] -> CFGBuild ()
addDummyPhiNode :: [(ScopeID, Name)] -> CFGBuild ()
addDummyPhiNode =
  ((ScopeID, Name) -> CFGBuild ())
-> [(ScopeID, Name)] -> CFGBuild ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    ( \(ScopeID
sid, Name
n) -> do
        (Type
tpe, Range
sl) <- ScopeID -> Name -> CFGBuild (Type, Range)
getTypeAndSL ScopeID
sid Name
n
        Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n) Type
tpe Range
sl
        SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> [(Var, ScopeID)] -> SSA
Phi Var
dst []
    )
  where
    getTypeAndSL :: ScopeID -> Name -> CFGBuild (AST.Type, SL.Range)
    getTypeAndSL :: ScopeID -> Name -> CFGBuild (Type, Range)
getTypeAndSL ScopeID
sid Name
name = do
      Map ScopeID SymbolTable
sts <- Getting
  (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
-> CFGBuild (Map ScopeID SymbolTable)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
 -> CFGBuild (Map ScopeID SymbolTable))
-> Getting
     (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
-> CFGBuild (Map ScopeID SymbolTable)
forall a b. (a -> b) -> a -> b
$ (SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
-> CFGContext -> Const (Map ScopeID SymbolTable) CFGContext
#semantic ((SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
 -> CFGContext -> Const (Map ScopeID SymbolTable) CFGContext)
-> ((Map ScopeID SymbolTable
     -> Const (Map ScopeID SymbolTable) (Map ScopeID SymbolTable))
    -> SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo)
-> Getting
     (Map ScopeID SymbolTable) CFGContext (Map ScopeID SymbolTable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScopeID SymbolTable
 -> Const (Map ScopeID SymbolTable) (Map ScopeID SymbolTable))
-> SemanticInfo -> Const (Map ScopeID SymbolTable) SemanticInfo
#symbolTables
      case ScopeID -> Map ScopeID SymbolTable -> Maybe SymbolTable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
sid Map ScopeID SymbolTable
sts Maybe SymbolTable
-> (SymbolTable -> Maybe (Either Argument FieldDecl))
-> Maybe (Either Argument FieldDecl)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
SE.lookupLocalVariableFromST Name
name of
        Maybe (Either Argument FieldDecl)
Nothing -> CompileError -> CFGBuild (Type, Range)
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild (Type, Range))
-> CompileError -> CFGBuild (Type, Range)
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> ScopeID -> Name) -> Name -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (Name -> ScopeID -> Name) (Name -> ScopeID -> Name)
"Unable to find variable" Format (Name -> ScopeID -> Name) (Name -> ScopeID -> Name)
-> Format Name (Name -> ScopeID -> Name)
-> Format Name (Name -> ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (ScopeID -> Name) (Name -> ScopeID -> Name)
forall r. Format r (Name -> r)
stext Format (ScopeID -> Name) (Name -> ScopeID -> Name)
-> Format Name (ScopeID -> Name)
-> Format Name (Name -> ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format (ScopeID -> Name) (ScopeID -> Name)
"in scope" Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) Name
name ScopeID
sid
        Just Either Argument FieldDecl
def -> do
          let tpe :: Type
tpe = (Argument -> Type)
-> (FieldDecl -> Type) -> Either Argument FieldDecl -> Type
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Getting Type Argument Type -> Argument -> Type
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Type Argument Type
#tpe) (Getting Type FieldDecl Type -> FieldDecl -> Type
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Type FieldDecl Type
#tpe) Either Argument FieldDecl
def
          let sl :: Range
sl = (Argument -> Range)
-> (FieldDecl -> Range) -> Either Argument FieldDecl -> Range
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Getting Range Argument Range -> Argument -> Range
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Range Argument Range
#loc) (Getting Range FieldDecl Range -> FieldDecl -> Range
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Range FieldDecl Range
#loc) Either Argument FieldDecl
def
          (Type, Range) -> CFGBuild (Type, Range)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
tpe, Range
sl)

recordPhiVar :: [(ScopeID, Name)] -> CFGBuild (Map (ScopeID, Name) Var)
recordPhiVar :: [(ScopeID, Name)] -> CFGBuild (Map (ScopeID, Name) Var)
recordPhiVar [(ScopeID, Name)]
symList = do
  [((ScopeID, Name), Var)]
varList <-
    ((ScopeID, Name) -> CFGBuild ((ScopeID, Name), Var))
-> [(ScopeID, Name)] -> CFGBuild [((ScopeID, Name), Var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
      ( \(ScopeID
sid, Name
n) -> do
          Var
var <- Name -> ScopeID -> CFGBuild Var
lookupSymInScope' Name
n ScopeID
sid
          ((ScopeID, Name), Var) -> CFGBuild ((ScopeID, Name), Var)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ScopeID
sid, Name
n), Var
var)
      )
      [(ScopeID, Name)]
symList
  Map (ScopeID, Name) Var -> CFGBuild (Map (ScopeID, Name) Var)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (ScopeID, Name) Var -> CFGBuild (Map (ScopeID, Name) Var))
-> Map (ScopeID, Name) Var -> CFGBuild (Map (ScopeID, Name) Var)
forall a b. (a -> b) -> a -> b
$ [((ScopeID, Name), Var)] -> Map (ScopeID, Name) Var
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((ScopeID, Name), Var)]
varList

patchPhiNode :: BBID -> BBID -> Map (ScopeID, Name) Var -> BBID -> Map (ScopeID, Name) Var -> CFGBuild ()
patchPhiNode :: ScopeID
-> ScopeID
-> Map (ScopeID, Name) Var
-> ScopeID
-> Map (ScopeID, Name) Var
-> CFGBuild ()
patchPhiNode ScopeID
bb ScopeID
s1 Map (ScopeID, Name) Var
varMap1 ScopeID
s2 Map (ScopeID, Name) Var
varMap2 = do
  Graph ScopeID BasicBlock CFGEdge
g <- CFGBuild (Graph ScopeID BasicBlock CFGEdge)
getGraph
  case ScopeID -> Graph ScopeID BasicBlock CFGEdge -> Maybe BasicBlock
forall ni nd ed.
(Eq ni, Ord ni) =>
ni -> Graph ni nd ed -> Maybe nd
G.lookupNode ScopeID
bb Graph ScopeID BasicBlock CFGEdge
g of
    Maybe BasicBlock
Nothing -> CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ()) -> CompileError -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"Basic block" Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int Format Name (ScopeID -> Name)
-> Format Name Name -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name Name
"not found.") ScopeID
bb
    Just BasicBlock
node -> do
      let ssaList :: [SSA]
ssaList = BasicBlock
node BasicBlock -> Getting [SSA] BasicBlock [SSA] -> [SSA]
forall s a. s -> Getting a s a -> a
^. Getting [SSA] BasicBlock [SSA]
#statements
      [SSA]
ssaList' <- (SSA -> CFGBuild SSA) -> [SSA] -> CFGBuild [SSA]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SSA -> CFGBuild SSA
patch [SSA]
ssaList
      GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ ScopeID
-> (BasicBlock -> BasicBlock)
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni nd ed.
(Eq ni, Ord ni) =>
ni -> (nd -> nd) -> GraphBuilder ni nd ed ()
G.adjustNode ScopeID
bb (ASetter BasicBlock BasicBlock [SSA] [SSA]
#statements ASetter BasicBlock BasicBlock [SSA] [SSA]
-> [SSA] -> BasicBlock -> BasicBlock
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [SSA]
ssaList')
  where
    patch :: SSA -> CFGBuild SSA
    patch :: SSA -> CFGBuild SSA
patch (Phi Var
dst []) = do
      (ScopeID
sid, Name
name) <- ScopeID -> CFGBuild (ScopeID, Name)
lookupVar' (Var
dst Var -> Getting ScopeID Var ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID Var ScopeID
#id)
      let v1 :: Maybe Var
v1 = (ScopeID, Name) -> Map (ScopeID, Name) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopeID
sid, Name
name) Map (ScopeID, Name) Var
varMap1
      let v2 :: Maybe Var
v2 = (ScopeID, Name) -> Map (ScopeID, Name) Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopeID
sid, Name
name) Map (ScopeID, Name) Var
varMap2
      case Maybe Var
v1 of
        Maybe Var
Nothing -> CompileError -> CFGBuild SSA
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild SSA) -> CompileError -> CFGBuild SSA
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Unable to find symbol" Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
name
        Just Var
v1' -> do
          case Maybe Var
v2 of
            Maybe Var
Nothing -> CompileError -> CFGBuild SSA
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild SSA) -> CompileError -> CFGBuild SSA
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing (Name -> CompileError) -> Name -> CompileError
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Unable to find symbol" Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
%+ Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
name
            Just Var
v2' -> SSA -> CFGBuild SSA
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSA -> CFGBuild SSA) -> SSA -> CFGBuild SSA
forall a b. (a -> b) -> a -> b
$ Var -> [(Var, ScopeID)] -> SSA
Phi Var
dst [(Var
v1', ScopeID
s1), (Var
v2', ScopeID
s2)]
    patch SSA
ssa = SSA -> CFGBuild SSA
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return SSA
ssa

{----------------------------------------
Build cfg from ast fragments
-----------------------------------------}

buildCFGs :: AST.ASTRoot -> CFGContext -> Either [CompileError] SingleFileCFG
buildCFGs :: ASTRoot -> CFGContext -> Either [CompileError] SingleFileCFG
buildCFGs root :: ASTRoot
root@(AST.ASTRoot [ImportDecl]
imports [FieldDecl]
globals [MethodDecl]
methods) CFGContext
context =
  CFGBuild SingleFileCFG
-> CFGState -> Either [CompileError] SingleFileCFG
runMonads CFGBuild SingleFileCFG
buildAll CFGState
initialState
  where
    runMonads :: CFGBuild SingleFileCFG
-> CFGState -> Either [CompileError] SingleFileCFG
runMonads CFGBuild SingleFileCFG
build CFGState
state =
      let (Either CompileError SingleFileCFG
res, CFGState
_) = State CFGState (Either CompileError SingleFileCFG)
-> CFGState -> (Either CompileError SingleFileCFG, CFGState)
forall s a. State s a -> s -> (a, s)
runState ((ReaderT
   CFGContext (State CFGState) (Either CompileError SingleFileCFG)
 -> CFGContext
 -> State CFGState (Either CompileError SingleFileCFG))
-> CFGContext
-> ReaderT
     CFGContext (State CFGState) (Either CompileError SingleFileCFG)
-> State CFGState (Either CompileError SingleFileCFG)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  CFGContext (State CFGState) (Either CompileError SingleFileCFG)
-> CFGContext -> State CFGState (Either CompileError SingleFileCFG)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CFGContext
context (ReaderT
   CFGContext (State CFGState) (Either CompileError SingleFileCFG)
 -> State CFGState (Either CompileError SingleFileCFG))
-> ReaderT
     CFGContext (State CFGState) (Either CompileError SingleFileCFG)
-> State CFGState (Either CompileError SingleFileCFG)
forall a b. (a -> b) -> a -> b
$ ExceptT
  CompileError (ReaderT CFGContext (State CFGState)) SingleFileCFG
-> ReaderT
     CFGContext (State CFGState) (Either CompileError SingleFileCFG)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   CompileError (ReaderT CFGContext (State CFGState)) SingleFileCFG
 -> ReaderT
      CFGContext (State CFGState) (Either CompileError SingleFileCFG))
-> ExceptT
     CompileError (ReaderT CFGContext (State CFGState)) SingleFileCFG
-> ReaderT
     CFGContext (State CFGState) (Either CompileError SingleFileCFG)
forall a b. (a -> b) -> a -> b
$ CFGBuild SingleFileCFG
-> ExceptT
     CompileError (ReaderT CFGContext (State CFGState)) SingleFileCFG
forall a.
CFGBuild a
-> ExceptT CompileError (ReaderT CFGContext (State CFGState)) a
runCFGBuild CFGBuild SingleFileCFG
build) CFGState
state
       in case Either CompileError SingleFileCFG
res of
            Left CompileError
e -> [CompileError] -> Either [CompileError] SingleFileCFG
forall a b. a -> Either a b
Left [CompileError
e]
            Right SingleFileCFG
a -> SingleFileCFG -> Either [CompileError] SingleFileCFG
forall a b. b -> Either a b
Right SingleFileCFG
a
    buildAll :: CFGBuild SingleFileCFG
buildAll = do
      [(Var, Type)]
globals <- [FieldDecl] -> CFGBuild [(Var, Type)]
populateGlobals [FieldDecl]
globals
      [Name]
declares <- [ImportDecl] -> CFGBuild [Name]
handleImportFunctions [ImportDecl]
imports
      Map Name CFG
cfgs <-
        Map Name (CFGBuild CFG) -> CFGBuild (Map Name CFG)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Map Name (m a) -> m (Map Name a)
sequence (Map Name (CFGBuild CFG) -> CFGBuild (Map Name CFG))
-> Map Name (CFGBuild CFG) -> CFGBuild (Map Name CFG)
forall a b. (a -> b) -> a -> b
$
          [(Name, CFGBuild CFG)] -> Map Name (CFGBuild CFG)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            ([MethodDecl]
methods [MethodDecl]
-> (MethodDecl -> (Name, CFGBuild CFG)) -> [(Name, CFGBuild CFG)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \MethodDecl
method -> (MethodDecl
method MethodDecl -> Getting Name MethodDecl Name -> Name
forall s a. s -> Getting a s a -> a
^. (MethodSig -> Const Name MethodSig)
-> MethodDecl -> Const Name MethodDecl
#sig ((MethodSig -> Const Name MethodSig)
 -> MethodDecl -> Const Name MethodDecl)
-> ((Name -> Const Name Name) -> MethodSig -> Const Name MethodSig)
-> Getting Name MethodDecl Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const Name Name) -> MethodSig -> Const Name MethodSig
#name, MethodDecl -> CFGBuild CFG
buildMethod MethodDecl
method))
      SingleFileCFG -> CFGBuild SingleFileCFG
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (SingleFileCFG -> CFGBuild SingleFileCFG)
-> SingleFileCFG -> CFGBuild SingleFileCFG
forall a b. (a -> b) -> a -> b
$ [Name] -> [(Var, Type)] -> Map Name CFG -> SingleFileCFG
SingleFileCFG [Name]
declares [(Var, Type)]
globals Map Name CFG
cfgs

populateGlobals :: [AST.FieldDecl] -> CFGBuild [(Var, AST.Type)]
populateGlobals :: [FieldDecl] -> CFGBuild [(Var, Type)]
populateGlobals [FieldDecl]
globals = 
    (FieldDecl -> CFGBuild (Var, Type))
-> [FieldDecl] -> CFGBuild [(Var, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
      ( \(AST.FieldDecl Name
name Type
tpe Range
loc) -> do
          Var
ptr <- Name -> Type -> Range -> CFGBuild Var
newGlobal Name
name Type
tpe Range
loc
          (Var, Type) -> CFGBuild (Var, Type)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
ptr, Type
tpe)
      )
      [FieldDecl]
globals

handleImportFunctions :: [AST.ImportDecl] -> CFGBuild [Name]
handleImportFunctions :: [ImportDecl] -> CFGBuild [Name]
handleImportFunctions [ImportDecl]
imports = [Name] -> CFGBuild [Name]
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> CFGBuild [Name]) -> [Name] -> CFGBuild [Name]
forall a b. (a -> b) -> a -> b
$ [ImportDecl]
imports [ImportDecl] -> (ImportDecl -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Getting Name ImportDecl Name -> ImportDecl -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name ImportDecl Name
#name

buildMethod :: AST.MethodDecl -> CFGBuild CFG
buildMethod :: MethodDecl -> CFGBuild CFG
buildMethod decl :: MethodDecl
decl@AST.MethodDecl {$sel:sig:MethodDecl :: MethodDecl -> MethodSig
sig = MethodSig
sig, $sel:block:MethodDecl :: MethodDecl -> Block
block = block :: Block
block@(AST.Block [FieldDecl]
_ [Statement]
stmts ScopeID
sid)} = do
  CFGBuild ()
checkStmts
  CFG -> CFGBuild ()
setCFG (CFG -> CFGBuild ()) -> CFG -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Graph ScopeID BasicBlock CFGEdge
-> ScopeID -> ScopeID -> [Var] -> MethodSig -> CFG
CFG Graph ScopeID BasicBlock CFGEdge
forall ni nd ed. Graph ni nd ed
G.empty ScopeID
0 ScopeID
0 [] MethodSig
sig
  ScopeID
entry <- CFGBuild ScopeID
createEmptyBB
  ScopeID -> CFGBuild ()
setFunctionEntry ScopeID
entry
  ScopeID
exit <- CFGBuild ScopeID
createEmptyBB
  ScopeID -> CFGBuild ()
setFunctionExit ScopeID
exit
  (ScopeID
blockH, ScopeID
blockT, [Var]
vars) <- [Argument] -> Block -> CFGBuild (ScopeID, ScopeID, [Var])
buildBlock (MethodSig
sig MethodSig -> Getting [Argument] MethodSig [Argument] -> [Argument]
forall s a. s -> Getting a s a -> a
^. Getting [Argument] MethodSig [Argument]
#args) Block
block
  GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ do
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
entry ScopeID
blockH CFGEdge
SeqEdge
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
blockT ScopeID
exit CFGEdge
SeqEdge
  ScopeID
newExit <- ScopeID -> MethodDecl -> CFGBuild ScopeID
replaceExitBlock ScopeID
exit MethodDecl
decl
  #cfg . _Just . #arguments .= vars
  CFGBuild CFG
getCFG

defaultImm :: AST.Type -> VarOrImm
defaultImm :: Type -> VarOrImm
defaultImm Type
AST.Void = Int64 -> VarOrImm
IntImm Int64
0
defaultImm Type
AST.BoolType = Bool -> VarOrImm
BoolImm Bool
False 
defaultImm Type
AST.CharType = Char -> VarOrImm
CharImm (Char -> VarOrImm) -> Char -> VarOrImm
forall a b. (a -> b) -> a -> b
$ ScopeID -> Char
chr ScopeID
0
defaultImm Type
AST.IntType = Int64 -> VarOrImm
IntImm Int64
0
defaultImm (AST.ArrayType Type
_ Int64
_) = Int64 -> VarOrImm
PtrImm Int64
0
defaultImm (AST.Ptr Type
_) = Int64 -> VarOrImm
PtrImm Int64
0

-- Replace previously created exit block so id's are always monotonically increasing.
-- Also add a return statement as a default to exit block.
replaceExitBlock :: BBID -> AST.MethodDecl -> CFGBuild BBID
replaceExitBlock :: ScopeID -> MethodDecl -> CFGBuild ScopeID
replaceExitBlock ScopeID
prevExit MethodDecl
decl = do
  ScopeID
exit <- [SSA] -> CFGBuild ScopeID
createBB [SSA
retStmt]
  Maybe CFG
g' <- Getting (Maybe CFG) CFGState (Maybe CFG) -> CFGBuild (Maybe CFG)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe CFG) CFGState (Maybe CFG)
#cfg
  case Maybe CFG
g' of
    Maybe CFG
Nothing -> () -> CFGBuild ()
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just CFG
g -> do
      let edges :: [(ScopeID, ScopeID, CFGEdge)]
edges = Graph ScopeID BasicBlock CFGEdge -> [(ScopeID, ScopeID, CFGEdge)]
forall ni nd ed.
(Eq ni, Ord ni) =>
Graph ni nd ed -> [(ni, ni, ed)]
G.edgeToList (Graph ScopeID BasicBlock CFGEdge -> [(ScopeID, ScopeID, CFGEdge)])
-> Graph ScopeID BasicBlock CFGEdge
-> [(ScopeID, ScopeID, CFGEdge)]
forall a b. (a -> b) -> a -> b
$ CFG
g CFG
-> Getting
     (Graph ScopeID BasicBlock CFGEdge)
     CFG
     (Graph ScopeID BasicBlock CFGEdge)
-> Graph ScopeID BasicBlock CFGEdge
forall s a. s -> Getting a s a -> a
^. Getting
  (Graph ScopeID BasicBlock CFGEdge)
  CFG
  (Graph ScopeID BasicBlock CFGEdge)
#graph
      let nodes :: [(ScopeID, BasicBlock)]
nodes = Graph ScopeID BasicBlock CFGEdge -> [(ScopeID, BasicBlock)]
forall ni nd ed. (Eq ni, Ord ni) => Graph ni nd ed -> [(ni, nd)]
G.nodeToList (Graph ScopeID BasicBlock CFGEdge -> [(ScopeID, BasicBlock)])
-> Graph ScopeID BasicBlock CFGEdge -> [(ScopeID, BasicBlock)]
forall a b. (a -> b) -> a -> b
$ CFG
g CFG
-> Getting
     (Graph ScopeID BasicBlock CFGEdge)
     CFG
     (Graph ScopeID BasicBlock CFGEdge)
-> Graph ScopeID BasicBlock CFGEdge
forall s a. s -> Getting a s a -> a
^. Getting
  (Graph ScopeID BasicBlock CFGEdge)
  CFG
  (Graph ScopeID BasicBlock CFGEdge)
#graph
      GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ [(ScopeID, ScopeID, CFGEdge)]
-> ((ScopeID, ScopeID, CFGEdge)
    -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(ScopeID, ScopeID, CFGEdge)]
edges (ScopeID
-> (ScopeID, ScopeID, CFGEdge)
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
updateExitEdge ScopeID
exit)
  ScopeID -> CFGBuild ScopeID
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ScopeID
exit
  where
    retStmt :: SSA
retStmt = case MethodDecl
decl MethodDecl
-> Getting (Maybe Type) MethodDecl (Maybe Type) -> Maybe Type
forall s a. s -> Getting a s a -> a
^. (MethodSig -> Const (Maybe Type) MethodSig)
-> MethodDecl -> Const (Maybe Type) MethodDecl
#sig ((MethodSig -> Const (Maybe Type) MethodSig)
 -> MethodDecl -> Const (Maybe Type) MethodDecl)
-> ((Maybe Type -> Const (Maybe Type) (Maybe Type))
    -> MethodSig -> Const (Maybe Type) MethodSig)
-> Getting (Maybe Type) MethodDecl (Maybe Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Type -> Const (Maybe Type) (Maybe Type))
-> MethodSig -> Const (Maybe Type) MethodSig
#tpe of
            Maybe Type
Nothing -> Maybe VarOrImm -> SSA
Return Maybe VarOrImm
forall a. Maybe a
Nothing
            Just Type
tpe -> Maybe VarOrImm -> SSA
Return (Maybe VarOrImm -> SSA) -> Maybe VarOrImm -> SSA
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Maybe VarOrImm
forall a. a -> Maybe a
Just (VarOrImm -> Maybe VarOrImm) -> VarOrImm -> Maybe VarOrImm
forall a b. (a -> b) -> a -> b
$ Type -> VarOrImm
defaultImm Type
tpe
    updateExitEdge :: ScopeID
-> (ScopeID, ScopeID, CFGEdge)
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
updateExitEdge ScopeID
exit (ScopeID
src, ScopeID
dst, CFGEdge
ed) = do
      Bool
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScopeID
src ScopeID -> ScopeID -> Bool
forall a. Eq a => a -> a -> Bool
== ScopeID
prevExit)
        (ScopeID -> ScopeID -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni nd ed.
(Eq ni, Ord ni) =>
ni -> ni -> GraphBuilder ni nd ed ()
G.deleteEdge ScopeID
src ScopeID
dst GraphBuilder ScopeID BasicBlock CFGEdge ()
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b.
GraphBuilder ScopeID BasicBlock CFGEdge a
-> GraphBuilder ScopeID BasicBlock CFGEdge b
-> GraphBuilder ScopeID BasicBlock CFGEdge b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
exit ScopeID
dst CFGEdge
ed)
      Bool
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScopeID
dst ScopeID -> ScopeID -> Bool
forall a. Eq a => a -> a -> Bool
== ScopeID
prevExit)
        (ScopeID -> ScopeID -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni nd ed.
(Eq ni, Ord ni) =>
ni -> ni -> GraphBuilder ni nd ed ()
G.deleteEdge ScopeID
src ScopeID
dst GraphBuilder ScopeID BasicBlock CFGEdge ()
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
-> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b.
GraphBuilder ScopeID BasicBlock CFGEdge a
-> GraphBuilder ScopeID BasicBlock CFGEdge b
-> GraphBuilder ScopeID BasicBlock CFGEdge b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
src ScopeID
exit CFGEdge
ed)


buildBlock :: [AST.Argument] -> AST.Block -> CFGBuild (BBID, BBID, [Var])
buildBlock :: [Argument] -> Block -> CFGBuild (ScopeID, ScopeID, [Var])
buildBlock [Argument]
args block :: Block
block@AST.Block {$sel:stmts:Block :: Block -> [Statement]
stmts = [Statement]
stmts} = do
  CFGBuild ()
checkStmts
  -- always create an empty BB at the start
  ScopeID
head <- CFGBuild ScopeID
createEmptyBB
  -- record parent scope
  ScopeID
parentScope <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#astScope
  -- enter new block scope
  let scopeID :: ScopeID
scopeID = Block
block Block -> Getting ScopeID Block ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID Block ScopeID
#blockID
  ScopeID -> CFGBuild ()
setASTScope ScopeID
scopeID
  -- create a new varmap for this scope
  #sym2var %= Map.insert scopeID (SymVarMap Map.empty $ Just parentScope)
  -- handle method arguments
  [Var]
arguments <- (Argument -> CFGBuild Var) -> [Argument] -> CFGBuild [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(AST.Argument Name
name Type
tpe Range
loc) -> Maybe Name -> Type -> Range -> CFGBuild Var
newLocal (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) Type
tpe Range
loc) [Argument]
args
  -- handle variable declarations
  (FieldDecl -> CFGBuild Var) -> [FieldDecl] -> CFGBuild ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(AST.FieldDecl Name
name Type
tpe Range
loc) -> Maybe Name -> Type -> Range -> CFGBuild Var
allocaOnStack (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) Type
tpe Range
loc) (Block
block Block -> Getting [FieldDecl] Block [FieldDecl] -> [FieldDecl]
forall s a. s -> Getting a s a -> a
^. Getting [FieldDecl] Block [FieldDecl]
#vars)
  -- handle statements
  BBTransition
stmtT <- (BBTransition -> Statement -> CFGBuild BBTransition)
-> BBTransition -> [Statement] -> CFGBuild BBTransition
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\BBTransition
_ Statement
s -> Statement -> CFGBuild BBTransition
buildStatement Statement
s) (ScopeID -> BBTransition
StayIn ScopeID
head) [Statement]
stmts
  -- connect last basic block with dangling statements if necessary
  ScopeID
tail <- case BBTransition
stmtT of
    Deadend ScopeID
bbid -> do
      CFGBuild ()
checkStmts
      ScopeID -> CFGBuild ScopeID
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ScopeID
bbid
    StayIn ScopeID
bbid ->
      -- collect dangling statements, possibly left by some previous basic block.
      CFGBuild ScopeID
finishCurrentBB
    TailAt ScopeID
bbid -> do
      -- some basic blocks were created, we check for dangling statements
      CFGBuild ()
checkStmts
      ScopeID -> CFGBuild ScopeID
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ScopeID
bbid
  -- recover parent scope
  ScopeID -> CFGBuild ()
setASTScope ScopeID
parentScope
  (ScopeID, ScopeID, [Var]) -> CFGBuild (ScopeID, ScopeID, [Var])
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopeID
head, ScopeID
tail, [Var]
arguments)

buildAssignOp :: AST.Location -> AST.AssignOp -> Maybe AST.Expr -> CFGBuild Var
buildAssignOp :: Location -> AssignOp -> Maybe Expr -> CFGBuild Var
buildAssignOp Location
_ AssignOp
AST.EqlAssign (Just Expr
expr) = Expr -> CFGBuild Var
buildExpr Expr
expr
buildAssignOp Location
location AssignOp
AST.IncAssign (Just Expr
expr) = do
  Var
prev <- Location -> CFGBuild Var
buildReadFromLocation Location
location
  Var
addition <- Expr -> CFGBuild Var
buildExpr Expr
expr
  Var
dst' <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing (Var
prev Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe) (Var -> Range
SSA.loc Var
prev)
  SSA -> CFGBuild ()
addSSA (Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
SSA.Arith Var
dst' ArithOp
AST.Plus (Var -> VarOrImm
Variable Var
prev) (Var -> VarOrImm
Variable Var
addition))
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst'
buildAssignOp Location
location AssignOp
AST.DecAssign (Just Expr
expr) = do
  Var
prev <- Location -> CFGBuild Var
buildReadFromLocation Location
location
  Var
addition <- Expr -> CFGBuild Var
buildExpr Expr
expr
  Var
dst' <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing (Var
prev Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe) (Var -> Range
SSA.loc Var
prev)
  SSA -> CFGBuild ()
addSSA (Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
SSA.Arith Var
dst' ArithOp
AST.Minus (Var -> VarOrImm
Variable Var
prev) (Var -> VarOrImm
Variable Var
addition))
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst'
buildAssignOp Location
location AssignOp
AST.PlusPlus Maybe Expr
Nothing = do
  Var
prev <- Location -> CFGBuild Var
buildReadFromLocation Location
location
  Var
dst' <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing (Var
prev Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe) (Var -> Range
SSA.loc Var
prev)
  SSA -> CFGBuild ()
addSSA (Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
SSA.Arith Var
dst' ArithOp
AST.Plus (Var -> VarOrImm
Variable Var
prev) (Int64 -> VarOrImm
IntImm Int64
1))
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst'
buildAssignOp Location
location AssignOp
AST.MinusMinus Maybe Expr
Nothing = do
  Var
prev <- Location -> CFGBuild Var
buildReadFromLocation Location
location
  Var
dst' <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing (Var
prev Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe) (Var -> Range
SSA.loc Var
prev)
  SSA -> CFGBuild ()
addSSA (Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
SSA.Arith Var
dst' ArithOp
AST.Minus (Var -> VarOrImm
Variable Var
prev) (Int64 -> VarOrImm
IntImm Int64
1))
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst'
buildAssignOp Location
_ AssignOp
_ Maybe Expr
_ = CompileError -> CFGBuild Var
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild Var) -> CompileError -> CFGBuild Var
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError Maybe Range
forall a. Maybe a
Nothing Name
"Malformed assignment."

buildStatement :: AST.Statement -> CFGBuild BBTransition
buildStatement :: Statement -> CFGBuild BBTransition
buildStatement (AST.Statement (AST.AssignStmt (AST.Assignment Location
location AssignOp
op Maybe Expr
expr Range
_)) Range
_) = do
  Var
var <- Location -> AssignOp -> Maybe Expr -> CFGBuild Var
buildAssignOp Location
location AssignOp
op Maybe Expr
expr
  Location -> VarOrImm -> CFGBuild ()
buildWriteToLocation Location
location (Var -> VarOrImm
Variable Var
var)
  Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID CFGBuild ScopeID
-> (ScopeID -> BBTransition) -> CFGBuild BBTransition
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ScopeID -> BBTransition
StayIn
buildStatement (AST.Statement (AST.MethodCallStmt MethodCall
call) Range
_) = do
  MethodCall -> Type -> CFGBuild Var
buildMethodCall MethodCall
call Type
AST.Void
  Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID CFGBuild ScopeID
-> (ScopeID -> BBTransition) -> CFGBuild BBTransition
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ScopeID -> BBTransition
StayIn
buildStatement (AST.Statement (AST.IfStmt Expr
expr Block
ifBlock Maybe Block
maybeElseBlock) Range
loc) = do
  let phiBlocks :: [ScopeID]
phiBlocks = case Maybe Block
maybeElseBlock of
        Maybe Block
Nothing -> [Block
ifBlock Block -> Getting ScopeID Block ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID Block ScopeID
#blockID]
        Just Block
elseBlock -> [Block
ifBlock Block -> Getting ScopeID Block ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID Block ScopeID
#blockID, Block
elseBlock Block -> Getting ScopeID Block ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID Block ScopeID
#blockID]
  -- Finish previous basic block. Also append pred calculation to it.
  [(ScopeID, Name)]
phiList <- [ScopeID] -> CFGBuild [(ScopeID, Name)]
inferPhiList [ScopeID]
phiBlocks
  Var
predVar <- Expr -> CFGBuild Var
buildExpr Expr
expr
  ScopeID
prevBB <- CFGBuild ScopeID
finishCurrentBB
  Map (ScopeID, Name) Var
prevBBPhiList <- [(ScopeID, Name)] -> CFGBuild (Map (ScopeID, Name) Var)
recordPhiVar [(ScopeID, Name)]
phiList
  -- Build if body
  (ScopeID
ifHead, ScopeID
ifTail, [Var]
_) <- [Argument] -> Block -> CFGBuild (ScopeID, ScopeID, [Var])
buildBlock [] Block
ifBlock
  Map (ScopeID, Name) Var
ifBBPhiList <- [(ScopeID, Name)] -> CFGBuild (Map (ScopeID, Name) Var)
recordPhiVar [(ScopeID, Name)]
phiList
  GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
prevBB ScopeID
ifHead (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Pred (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
predVar)
  -- Build else body if it exist.
  case Maybe Block
maybeElseBlock of
    (Just Block
elseBlock) -> do
      (ScopeID
elseHead, ScopeID
elseTail, [Var]
_) <- [Argument] -> Block -> CFGBuild (ScopeID, ScopeID, [Var])
buildBlock [] Block
elseBlock
      Map (ScopeID, Name) Var
elseBBPhiList <- [(ScopeID, Name)] -> CFGBuild (Map (ScopeID, Name) Var)
recordPhiVar [(ScopeID, Name)]
phiList
      [(ScopeID, Name)] -> CFGBuild ()
addDummyPhiNode [(ScopeID, Name)]
phiList
      ScopeID
tail <- CFGBuild ScopeID
finishCurrentBB
      GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ do
        ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
prevBB ScopeID
elseHead (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Complement (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
predVar
        ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
ifTail ScopeID
tail CFGEdge
SeqEdge
        ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
elseTail ScopeID
tail CFGEdge
SeqEdge
      ScopeID
-> ScopeID
-> Map (ScopeID, Name) Var
-> ScopeID
-> Map (ScopeID, Name) Var
-> CFGBuild ()
patchPhiNode ScopeID
tail ScopeID
ifTail Map (ScopeID, Name) Var
ifBBPhiList ScopeID
elseTail Map (ScopeID, Name) Var
elseBBPhiList
      BBTransition -> CFGBuild BBTransition
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (BBTransition -> CFGBuild BBTransition)
-> BBTransition -> CFGBuild BBTransition
forall a b. (a -> b) -> a -> b
$ ScopeID -> BBTransition
TailAt ScopeID
tail
    Maybe Block
Nothing -> do
      [(ScopeID, Name)] -> CFGBuild ()
addDummyPhiNode [(ScopeID, Name)]
phiList
      ScopeID
tail <- CFGBuild ScopeID
finishCurrentBB
      GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ do
        ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
prevBB ScopeID
tail (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Complement (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
predVar
        ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
ifTail ScopeID
tail CFGEdge
SeqEdge
      ScopeID
-> ScopeID
-> Map (ScopeID, Name) Var
-> ScopeID
-> Map (ScopeID, Name) Var
-> CFGBuild ()
patchPhiNode ScopeID
tail ScopeID
prevBB Map (ScopeID, Name) Var
prevBBPhiList ScopeID
ifTail Map (ScopeID, Name) Var
ifBBPhiList
      BBTransition -> CFGBuild BBTransition
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (BBTransition -> CFGBuild BBTransition)
-> BBTransition -> CFGBuild BBTransition
forall a b. (a -> b) -> a -> b
$ ScopeID -> BBTransition
TailAt ScopeID
tail
buildStatement (AST.Statement (AST.ForStmt Maybe Assignment
init Expr
pred Maybe Assignment
update Block
block) Range
loc) = do
  [(ScopeID, Name)]
phiList <- [ScopeID] -> CFGBuild [(ScopeID, Name)]
inferPhiList [Block
block Block -> Getting ScopeID Block ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID Block ScopeID
#blockID]
  -- append init to previous block
  case Maybe Assignment
init of
    Maybe Assignment
Nothing -> () -> CFGBuild ()
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Assignment
init -> CFGBuild BBTransition -> CFGBuild ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CFGBuild BBTransition -> CFGBuild ())
-> CFGBuild BBTransition -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Statement -> CFGBuild BBTransition
buildStatement (Statement -> CFGBuild BBTransition)
-> Statement -> CFGBuild BBTransition
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
AST.Statement (Assignment -> Statement_
AST.AssignStmt Assignment
init) (Assignment
init Assignment -> Getting Range Assignment Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range Assignment Range
#loc)
  ScopeID
prevBB <- CFGBuild ScopeID
finishCurrentBB
  Map (ScopeID, Name) Var
prevBBPhiList <- [(ScopeID, Name)] -> CFGBuild (Map (ScopeID, Name) Var)
recordPhiVar [(ScopeID, Name)]
phiList
  -- build the pred, also add dummy phi nodes at the start
  ScopeID
predHead <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  [(ScopeID, Name)] -> CFGBuild ()
addDummyPhiNode [(ScopeID, Name)]
phiList
  Var
predVar <- Expr -> CFGBuild Var
buildExpr Expr
pred
  ScopeID
predTail <- CFGBuild ScopeID
finishCurrentBB
  GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
prevBB ScopeID
predHead CFGEdge
SeqEdge)
  -- create a dummy update block for continue to jump to
  ScopeID
dummyUpdateBB <- CFGBuild ScopeID
createEmptyBB
  -- create a dummy tail block fro break to jump to
  ScopeID
tail <- CFGBuild ScopeID
createEmptyBB
  -- build for body and block connections
  Map (ScopeID, Name) Var
updateBBPhiList <-
    ScopeID
-> ScopeID
-> CFGBuild (Map (ScopeID, Name) Var)
-> CFGBuild (Map (ScopeID, Name) Var)
forall a. ScopeID -> ScopeID -> CFGBuild a -> CFGBuild a
withControlBlock
      ScopeID
dummyUpdateBB
      ScopeID
tail
      ( do
          (ScopeID
blockHead, ScopeID
blockTail, [Var]
_) <- [Argument] -> Block -> CFGBuild (ScopeID, ScopeID, [Var])
buildBlock [] Block
block
          -- create the actual update block(s)
          ScopeID
updateHead <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
          case Maybe Assignment
update of
            Maybe Assignment
Nothing -> () -> CFGBuild ()
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Assignment
update -> CFGBuild BBTransition -> CFGBuild ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CFGBuild BBTransition -> CFGBuild ())
-> CFGBuild BBTransition -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Statement -> CFGBuild BBTransition
buildStatement (Statement -> CFGBuild BBTransition)
-> Statement -> CFGBuild BBTransition
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
AST.Statement (Assignment -> Statement_
AST.AssignStmt Assignment
update) (Assignment
update Assignment -> Getting Range Assignment Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range Assignment Range
#loc)
          ScopeID
updateTail <- CFGBuild ScopeID
finishCurrentBB
          Map (ScopeID, Name) Var
updateBBPhiList <- [(ScopeID, Name)] -> CFGBuild (Map (ScopeID, Name) Var)
recordPhiVar [(ScopeID, Name)]
phiList
          GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ do
            ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
predTail ScopeID
blockHead (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Pred (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
predVar
            ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
predTail ScopeID
tail (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Complement (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
predVar
            ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
blockTail ScopeID
dummyUpdateBB CFGEdge
SeqEdge
            ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
dummyUpdateBB ScopeID
updateHead CFGEdge
SeqEdge
            ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
updateTail ScopeID
predHead CFGEdge
SeqEdge
          Map (ScopeID, Name) Var -> CFGBuild (Map (ScopeID, Name) Var)
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Map (ScopeID, Name) Var
updateBBPhiList
      )
  ScopeID
-> ScopeID
-> Map (ScopeID, Name) Var
-> ScopeID
-> Map (ScopeID, Name) Var
-> CFGBuild ()
patchPhiNode ScopeID
predHead ScopeID
prevBB Map (ScopeID, Name) Var
prevBBPhiList ScopeID
dummyUpdateBB Map (ScopeID, Name) Var
updateBBPhiList
  BBTransition -> CFGBuild BBTransition
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (BBTransition -> CFGBuild BBTransition)
-> BBTransition -> CFGBuild BBTransition
forall a b. (a -> b) -> a -> b
$ ScopeID -> BBTransition
TailAt ScopeID
tail
buildStatement (AST.Statement (AST.ReturnStmt Maybe Expr
expr') Range
loc) = do
  case Maybe Expr
expr' of
    (Just Expr
e) -> do
      Var
var <- Expr -> CFGBuild Var
buildExpr Expr
e
      SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe VarOrImm -> SSA
Return (Maybe VarOrImm -> SSA) -> Maybe VarOrImm -> SSA
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Maybe VarOrImm
forall a. a -> Maybe a
Just (VarOrImm -> Maybe VarOrImm) -> VarOrImm -> Maybe VarOrImm
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
var
    Maybe Expr
_ -> SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe VarOrImm -> SSA
Return Maybe VarOrImm
forall a. Maybe a
Nothing
  -- Go directly to function exit
  ScopeID
bbid <- CFGBuild ScopeID
finishCurrentBB
  ScopeID
funcTail <- CFGBuild ScopeID
getFunctionExit
  case ScopeID
funcTail of
    ScopeID
0 -> CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ()) -> CompileError -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) Name
"Return not in a function context."
    ScopeID
tail -> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
bbid ScopeID
tail CFGEdge
SeqEdge
  -- Create an unreachable bb in case there are still statements after
  -- this point.
  -- We could optimize unreachable blocks away in later passes.
  CFGBuild ScopeID
createEmptyBB CFGBuild ScopeID
-> (ScopeID -> BBTransition) -> CFGBuild BBTransition
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ScopeID -> BBTransition
Deadend
buildStatement (AST.Statement Statement_
AST.ContinueStmt Range
loc) = do
  ScopeID
bbid <- CFGBuild ScopeID
finishCurrentBB
  Maybe ScopeID
controlH' <- CFGBuild (Maybe ScopeID)
getControlEntry
  case Maybe ScopeID
controlH' of
    Maybe ScopeID
Nothing -> CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ()) -> CompileError -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) Name
"Continue not in a loop context."
    Just ScopeID
controlH -> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
bbid ScopeID
controlH CFGEdge
SeqEdge
  CFGBuild ScopeID
createEmptyBB CFGBuild ScopeID
-> (ScopeID -> BBTransition) -> CFGBuild BBTransition
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ScopeID -> BBTransition
Deadend
buildStatement (AST.Statement Statement_
AST.BreakStmt Range
loc) = do
  ScopeID
bbid <- CFGBuild ScopeID
finishCurrentBB
  Maybe ScopeID
controlT' <- CFGBuild (Maybe ScopeID)
getControlExit
  case Maybe ScopeID
controlT' of
    Maybe ScopeID
Nothing -> CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ()) -> CompileError -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) Name
"Break not in a loop context."
    Just ScopeID
controlT -> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
bbid ScopeID
controlT CFGEdge
SeqEdge
  CFGBuild ScopeID
createEmptyBB CFGBuild ScopeID
-> (ScopeID -> BBTransition) -> CFGBuild BBTransition
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ScopeID -> BBTransition
Deadend

buildExpr :: AST.Expr -> CFGBuild Var
buildExpr :: Expr -> CFGBuild Var
buildExpr (AST.Expr (AST.LocationExpr Location
location) Type
tpe Range
_) = Location -> CFGBuild Var
buildReadFromLocation Location
location
buildExpr (AST.Expr (AST.MethodCallExpr MethodCall
call) Type
tpe Range
_) = MethodCall -> Type -> CFGBuild Var
buildMethodCall MethodCall
call Type
tpe
buildExpr (AST.Expr (AST.ExternCallExpr Name
name [Expr]
args) Type
tpe Range
loc) =
  MethodCall -> Type -> CFGBuild Var
buildMethodCall (Name -> [Expr] -> Range -> MethodCall
AST.MethodCall Name
name [Expr]
args Range
loc) Type
tpe
buildExpr (AST.Expr (AST.IntLiteralExpr Int64
val) Type
tpe Range
loc) = do
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm -> SSA
Assignment Var
dst (Int64 -> VarOrImm
IntImm Int64
val)
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.BoolLiteralExpr Bool
val) Type
tpe Range
loc) = do
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm -> SSA
Assignment Var
dst (Bool -> VarOrImm
BoolImm Bool
val)
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.CharLiteralExpr Char
val) Type
tpe Range
loc) = do
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm -> SSA
Assignment Var
dst (Char -> VarOrImm
CharImm Char
val)
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.StringLiteralExpr Name
val) Type
_ Range
loc) = do
  let len :: Int64
len = ScopeID -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Name -> ScopeID
Text.length Name
val) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1
  let tpe :: Type
tpe = Type -> Int64 -> Type
AST.ArrayType Type
AST.CharType Int64
len
  Var
ptr <- Maybe Name -> Type -> Range -> Locality -> CFGBuild Var
newVar Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc Locality
Local
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> Name -> Type -> SSA
AllocaStr Var
ptr (Name -> Name -> Name
Text.append Name
val Name
"\0") Type
tpe
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
ptr
buildExpr (AST.Expr (AST.ArithOpExpr ArithOp
op Expr
lhs Expr
rhs) Type
tpe Range
loc) = do
  Var
lhs' <- Expr -> CFGBuild Var
buildExpr Expr
lhs
  Var
rhs' <- Expr -> CFGBuild Var
buildExpr Expr
rhs
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
Arith Var
dst ArithOp
op (Var -> VarOrImm
Variable Var
lhs') (Var -> VarOrImm
Variable Var
rhs')
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.RelOpExpr RelOp
op Expr
lhs Expr
rhs) Type
tpe Range
loc) = do
  Var
lhs' <- Expr -> CFGBuild Var
buildExpr Expr
lhs
  Var
rhs' <- Expr -> CFGBuild Var
buildExpr Expr
rhs
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> RelOp -> VarOrImm -> VarOrImm -> SSA
Rel Var
dst RelOp
op (Var -> VarOrImm
Variable Var
lhs') (Var -> VarOrImm
Variable Var
rhs')
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.CondOpExpr CondOp
AST.And Expr
lhs Expr
rhs) Type
tpe Range
loc) = do
  Var
lhs' <- Expr -> CFGBuild Var
buildExpr Expr
lhs
  ScopeID
lhsTail <- CFGBuild ScopeID
finishCurrentBB
  ScopeID
rhsHead <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  Var
rhs' <- Expr -> CFGBuild Var
buildExpr Expr
rhs
  ScopeID
rhsTail <- CFGBuild ScopeID
finishCurrentBB
  ScopeID
tail <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ do
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
lhsTail ScopeID
rhsHead (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Pred (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
lhs'
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
lhsTail ScopeID
tail (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Complement (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
lhs'
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
rhsTail ScopeID
tail CFGEdge
SeqEdge
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> [(Var, ScopeID)] -> SSA
Phi Var
dst [(Var
lhs', ScopeID
lhsTail), (Var
rhs', ScopeID
rhsTail)]
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.CondOpExpr CondOp
AST.Or Expr
lhs Expr
rhs) Type
tpe Range
loc) = do
  Var
lhs' <- Expr -> CFGBuild Var
buildExpr Expr
lhs
  ScopeID
lhsTail <- CFGBuild ScopeID
finishCurrentBB
  ScopeID
rhsHead <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  Var
rhs' <- Expr -> CFGBuild Var
buildExpr Expr
rhs
  ScopeID
rhsTail <- CFGBuild ScopeID
finishCurrentBB
  ScopeID
bbid <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ do
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
lhsTail ScopeID
bbid (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Pred (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
lhs'
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
lhsTail ScopeID
rhsHead (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Complement (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
lhs'
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
rhsHead ScopeID
bbid CFGEdge
SeqEdge
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> [(Var, ScopeID)] -> SSA
Phi Var
dst [(Var
lhs', ScopeID
lhsTail), (Var
rhs', ScopeID
rhsTail)]
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.EqOpExpr EqOp
op Expr
lhs Expr
rhs) Type
tpe Range
loc) = do
  Var
lhs' <- Expr -> CFGBuild Var
buildExpr Expr
lhs
  Var
rhs' <- Expr -> CFGBuild Var
buildExpr Expr
rhs
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> EqOp -> VarOrImm -> VarOrImm -> SSA
Eq Var
dst EqOp
op (Var -> VarOrImm
Variable Var
lhs') (Var -> VarOrImm
Variable Var
rhs')
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.NegOpExpr NegOp
op Expr
opr) Type
tpe Range
loc) = do
  Var
opr' <- Expr -> CFGBuild Var
buildExpr Expr
opr
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> NegOp -> VarOrImm -> SSA
Neg Var
dst NegOp
op (Var -> VarOrImm
Variable Var
opr')
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.NotOpExpr NotOp
op Expr
opr) Type
tpe Range
loc) = do
  Var
opr' <- Expr -> CFGBuild Var
buildExpr Expr
opr
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> NotOp -> VarOrImm -> SSA
Not Var
dst NotOp
op (Var -> VarOrImm
Variable Var
opr')
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.ChoiceOpExpr ChoiceOp
op Expr
e1 Expr
e2 Expr
e3) Type
tpe Range
loc) = do
  Var
pred' <- Expr -> CFGBuild Var
buildExpr Expr
e1
  ScopeID
prev <- CFGBuild ScopeID
finishCurrentBB
  Var
exprT' <- Expr -> CFGBuild Var
buildExpr Expr
e2
  ScopeID
bbTHead <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  ScopeID
bbTTail <- CFGBuild ScopeID
finishCurrentBB
  ScopeID
bbFHead <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  Var
exprF' <- Expr -> CFGBuild Var
buildExpr Expr
e3
  ScopeID
bbFTail <- CFGBuild ScopeID
finishCurrentBB
  ScopeID
tail <- Getting ScopeID CFGState ScopeID -> CFGBuild ScopeID
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ScopeID CFGState ScopeID
#currentBBID
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a. GraphBuilder ScopeID BasicBlock CFGEdge a -> CFGBuild ()
updateCFG (GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ())
-> GraphBuilder ScopeID BasicBlock CFGEdge () -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ do
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
prev ScopeID
bbTHead (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Pred (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
pred'
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
prev ScopeID
bbFHead (CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ())
-> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall a b. (a -> b) -> a -> b
$ Condition -> CFGEdge
CondEdge (Condition -> CFGEdge) -> Condition -> CFGEdge
forall a b. (a -> b) -> a -> b
$ VarOrImm -> Condition
Complement (VarOrImm -> Condition) -> VarOrImm -> Condition
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm
Variable Var
pred'
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
bbTTail ScopeID
tail CFGEdge
SeqEdge
    ScopeID
-> ScopeID -> CFGEdge -> GraphBuilder ScopeID BasicBlock CFGEdge ()
forall ni ed nd.
(Eq ni, Ord ni) =>
ni -> ni -> ed -> GraphBuilder ni nd ed ()
G.addEdge ScopeID
bbFTail ScopeID
tail CFGEdge
SeqEdge
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> [(Var, ScopeID)] -> SSA
Phi Var
dst [(Var
exprT', ScopeID
bbTTail), (Var
exprF', ScopeID
bbFTail)]
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
buildExpr (AST.Expr (AST.LengthExpr Name
name) Type
tpe Range
loc) = do
  Var
array <- Name -> CFGBuild Var
lookupSym' Name
name
  Type
arrType <- case Var -> Maybe (Either Argument FieldDecl)
astDecl Var
array of
    Maybe (Either Argument FieldDecl)
Nothing -> CompileError -> CFGBuild Type
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild Type) -> CompileError -> CFGBuild Type
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) Name
"Unable to find array def"
    Just (Left (AST.Argument Name
_ Type
arrTpe Range
_)) -> Type -> CFGBuild Type
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
arrTpe
    Just (Right (AST.FieldDecl Name
_ Type
arrTpe Range
_)) -> Type -> CFGBuild Type
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
arrTpe
  case Type
arrType of
    AST.ArrayType Type
_ Int64
len -> do
      Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
      SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm -> SSA
Assignment Var
dst (Int64 -> VarOrImm
IntImm Int64
len)
      Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
    Type
_ ->
      CompileError -> CFGBuild Var
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild Var) -> CompileError -> CFGBuild Var
forall a b. (a -> b) -> a -> b
$
        Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) (Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Variable is not an array: " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
name)

buildReadFromLocation :: AST.Location -> CFGBuild Var
buildReadFromLocation :: Location -> CFGBuild Var
buildReadFromLocation (AST.Location Name
name Maybe Expr
idx Either Argument FieldDecl
def Type
tpe Range
loc) = do
  Var
var <- Name -> CFGBuild Var
lookupSym' Name
name
  -- NOTE: var^. #tpe might be different from tpe in AST.Location as we
  -- have altered type of global into pointers.
  case Var
var Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe of
    AST.ArrayType Type
eleType Int64
size -> do
      case Maybe Expr
idx of
        Maybe Expr
Nothing -> CompileError -> CFGBuild Var
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild Var) -> CompileError -> CFGBuild Var
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) Name
"Accessing array as a scalar."
        Just Expr
idxExpr -> do
          Var
idxVar <- Expr -> CFGBuild Var
buildExpr Expr
idxExpr
          Var
arrayPtr <- Name -> CFGBuild Var
lookupSym' Name
name
          Int64
eleSize <- case Type -> Maybe Int64
AST.dataSize Type
eleType of
            Maybe Int64
Nothing -> CompileError -> CFGBuild Int64
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild Int64) -> CompileError -> CFGBuild Int64
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) Name
"Array with void type element."
            Just Int64
sz -> Int64 -> CFGBuild Int64
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
sz
          Var
offset <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
AST.IntType Range
loc
          Var
ptr <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
AST.IntType Range
loc
          Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
eleType Range
loc
          SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
Arith Var
offset ArithOp
AST.Multiply (Var -> VarOrImm
Variable Var
idxVar) (Int64 -> VarOrImm
IntImm Int64
eleSize)
          SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
Arith Var
ptr ArithOp
AST.Plus (Var -> VarOrImm
Variable Var
arrayPtr) (Var -> VarOrImm
Variable Var
offset)
          SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm -> SSA
Load Var
dst (Var -> VarOrImm
Variable Var
ptr)
          Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
    AST.Ptr Type
tpe -> do
      Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
      SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm -> SSA
Load Var
dst (Var -> VarOrImm
Variable Var
var)
      Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst
    Type
_scalarType -> Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
var

buildWriteToLocation :: AST.Location -> VarOrImm -> CFGBuild ()
buildWriteToLocation :: Location -> VarOrImm -> CFGBuild ()
buildWriteToLocation (AST.Location Name
name Maybe Expr
idx Either Argument FieldDecl
def Type
tpe Range
loc) VarOrImm
src = do
  Var
var <- Name -> CFGBuild Var
lookupSym' Name
name
  case Var
var Var -> Getting Type Var Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type Var Type
#tpe of
    AST.ArrayType Type
eleType Int64
size ->
      case Maybe Expr
idx of
        Maybe Expr
Nothing -> CompileError -> CFGBuild ()
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild ()) -> CompileError -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) Name
"Accessing array as a scalar."
        Just Expr
idxExpr -> do
          Var
idx <- Expr -> CFGBuild Var
buildExpr Expr
idxExpr
          Var
arrayPtr <- Name -> CFGBuild Var
lookupSym' Name
name
          Int64
eleSize <- case Type -> Maybe Int64
AST.dataSize Type
eleType of
            Maybe Int64
Nothing -> CompileError -> CFGBuild Int64
forall a. CompileError -> CFGBuild a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> CFGBuild Int64) -> CompileError -> CFGBuild Int64
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc) Name
"Array with void type element."
            Just Int64
sz -> Int64 -> CFGBuild Int64
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
sz
          Var
offset <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
AST.IntType Range
loc
          Var
ptr <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
AST.IntType Range
loc
          SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
Arith Var
offset ArithOp
AST.Multiply (Var -> VarOrImm
Variable Var
idx) (Int64 -> VarOrImm
IntImm Int64
eleSize)
          SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> ArithOp -> VarOrImm -> VarOrImm -> SSA
Arith Var
ptr ArithOp
AST.Plus (Var -> VarOrImm
Variable Var
arrayPtr) (Var -> VarOrImm
Variable Var
offset)
          SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ VarOrImm -> VarOrImm -> SSA
Store (Var -> VarOrImm
Variable Var
ptr) VarOrImm
src
    AST.Ptr Type
tpe -> do
      SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ VarOrImm -> VarOrImm -> SSA
Store (Var -> VarOrImm
Variable Var
var) VarOrImm
src
    Type
_scalarType -> do
      Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) Type
tpe Range
loc
      SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> VarOrImm -> SSA
Assignment Var
dst VarOrImm
src

buildMethodCall :: AST.MethodCall -> AST.Type -> CFGBuild Var
buildMethodCall :: MethodCall -> Type -> CFGBuild Var
buildMethodCall (AST.MethodCall Name
name [Expr]
args Range
loc) Type
tpe = do
  [Var]
vars <- (Expr -> CFGBuild Var) -> [Expr] -> CFGBuild [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Expr -> CFGBuild Var
buildExpr [Expr]
args
  Var
dst <- Maybe Name -> Type -> Range -> CFGBuild Var
newLocal Maybe Name
forall a. Maybe a
Nothing Type
tpe Range
loc
  SSA -> CFGBuild ()
addSSA (SSA -> CFGBuild ()) -> SSA -> CFGBuild ()
forall a b. (a -> b) -> a -> b
$ Var -> Name -> [Var] -> SSA
MethodCall Var
dst Name
name [Var]
vars
  Var -> CFGBuild Var
forall a. a -> CFGBuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
dst