Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 67cc261b42
Fetching contributors…

Cannot retrieve contributors at this time

224 lines (174 sloc) 6.934 kb
{-# LANGUAGE ViewPatterns,GADTs,StandaloneDeriving,NoMonomorphismRestriction #-}
module Nam where
import Data.Aeson;
import Data.Attoparsec.Number
import Control.Monad
import Debug.Trace
import Data.Vector ((!))
import Compiler.Hoopl
import qualified Op
import qualified Data.Text as T
import qualified Data.Vector as V
import Control.Monad.State.Strict
import Insn
import Util
import qualified Data.Map as Map
type CM = StateT ConvertState M
data ConvertState = ConvertState {
uniqueReg :: Int,
letVars :: Map.Map String Expr
}
freshID :: CM Reg
freshID = do
state <- get
put (state{uniqueReg=uniqueReg state+1})
return $ uniqueReg state
lookupLetVar name = do
state <- get
case Map.lookup name (letVars state) of
Just r -> return r
Nothing -> error ("Can't lookup:"++name)
withVars :: [(String,Expr)] -> CM a -> CM a
withVars vars action = do
state <- get
put state{letVars=foldl (\m (name,reg) -> Map.insert name reg m) (letVars state) vars}
result <- action
modify(\s -> s{letVars=letVars state})
return result
simple val = return $ (emptyGraph,val)
-- TODO: pick better name?
composit args func = do
converted <- mapM convert args
let (setup,vals) = unzip converted
(extraSetup,ret) <- func vals
return ((foldl (<*>) emptyGraph setup) <*> extraSetup,ret)
basicInsn :: [Op.Op] -> ([Expr] -> Op) -> CM ((Graph Insn O O),Expr)
basicInsn args transform = do
id <- freshID
composit args (\vals ->
return (mkMiddle $ Op id (transform vals),Reg id))
branchInsn :: Expr -> Label -> Label -> AGraph Insn O C
branchInsn cond' trueLabel falseLabel =
aGraphOfGraph $ mkLast $ CondBranch cond' trueLabel falseLabel
convert :: Op.Op -> CM ((Graph Insn O O),Expr)
-- ops which map directly to Expr
convert (Op.Double d) = simple $ Double d
convert (Op.StrLit str) = simple $ StrLit str
convert (Op.ScopedLex str) = simple $ ScopedLex str
convert (Op.CoreLex str) = simple $ CoreLex str
convert (Op.LetVar str) = do
r <- lookupLetVar str
simple $ r
-- HACKS
convert (Op.Ann _ op) = convert op
convert (Op.Box _ op) = convert op
convert (Op.Const op) = convert op
convert (Op.Prog ops) = composit ops (\vals -> return (emptyGraph,last vals))
convert (Op.Subcall args) = basicInsn args Subcall
convert (Op.Fetch arg) = basicInsn [arg] (\[arg] -> Fetch arg)
convert (Op.ObjGetBool arg) = basicInsn [arg] (\[arg] -> ObjGetBool arg)
convert (Op.BifPlus a b) = basicInsn [a,b] (\[a,b] -> BifPlus a b)
convert (Op.BifDivide a b) = basicInsn [a,b] (\[a,b] -> BifDivide a b)
convert (Op.BifMinus a b) = basicInsn [a,b] (\[a,b] -> BifMinus a b)
convert (Op.Sink arg) = convert arg
convert (Op.Ternary cond true false) = do
result <- freshID
(condSetup',cond') <- convert cond
let branch op = do
(setup,val) <- convert op
return $ aGraphOfGraph $ setup <*> mkMiddle (Op result (RegSet val))
true' <- branch true
false' <- branch false
ifStmt <- lift $ graphOfAGraph $ mkIfThenElse (branchInsn cond') true' false'
return $ (condSetup' <*> ifStmt,Reg result)
convert (Op.LetN pairs body) =
let (regs,values) = unzip pairs in composit values (
\expr -> do
withVars (zip regs expr) (convert body)
)
-- HACK those nodes shouldn't be ignored
convert (Op.Unknown value) = error $ "Can't convert: " ++ (toStr value)
convert (other) = error $ "Can't convert: " ++ (show other)
--convert (expr) = do
-- (setup,val) <- convertToExpr expr
-- return setup
data Xref = Xref {
unit :: String, -- Names unit of origin
index :: Integer, -- Indexes into unit's xref array
xref_name :: String -- Descriptive name for debugging
} deriving Show
data Unit = Unit {
mainline_ref :: Xref, -- Xref to mainline subroutine
name :: String, -- Unit's unique name
-- log :: ... -- Mostly unused vestige of last stash system
setting :: String, -- Name of setting unit or null
bottom_ref :: Maybe Xref, -- Xref to sub containing {YOU_ARE_HERE}, or null
filename :: String, -- Filename of source code or null
modtime :: Integer, -- Seconds since 1970-01-01
xref :: [XrefThing] -- Resolves refs from other units
-- tdeps :: TDep -- Holds dependency data for recompilation
-- stash_root :: StNode -- Trie holding classes and global variables
} deriving Show
{-
data Sub =
name string Sub's name for backtraces
outer_xref Xref OUTER:: sub, may be in a setting unit
flags number [1]
children num[] Supports tree traversals
param_role_hack ... [2]
augment_hack ... [3]
hint_hack ... [4]
is_phaser number [5]
body_of Xref Only valid in immediate block of class {} et al
in_class Xref Innermost enclosing body_of
cur_pkg str[] OUR:: as a list of names
class string &?BLOCK.WHAT; "Sub" or "Regex"
ltm LtmNode Only for regexes; stores declarative prefix
exports str[][] List of global names
signature Param[] May be null in exotic cases
lexicals Lex[] Come in multiple forms
nam ... See description of opcodes earlier-}
data XrefThing = Sub {
subName :: String,
nam :: Op.Op
} | Missing | Other String
deriving Show
parseXrefThing "sub" a = do
subName_ <- parseJSON (a ! 1)
return $ Sub {subName=subName_,nam=Op.rawOpsToOp (a ! 17)}
parseXrefThing thing_type _ = return $ Other thing_type
instance FromJSON XrefThing where
parseJSON (Array a) = do
thing_type <- parseJSON (a ! 0)
parseXrefThing thing_type a
parseJSON Null = return $ Missing
parseJSON other = fail ("Can't parse XrefThing:"++(show other))
instance FromJSON Xref where
parseJSON (Array a) = do
unit <- parseJSON (a ! 0)
index <- parseJSON (a ! 1)
xref_name <- parseJSON (a ! 2)
return $ Xref { unit=unit, index=index, xref_name=xref_name }
parseJSON other = fail ("Can't parse Xref:"++(show other))
instance FromJSON Unit where
parseJSON (Array a) = do
mainline_ref <- parseJSON (a ! 0)
name <- parseJSON (a ! 1)
-- skipping log and setting
--
setting <- parseJSON (a ! 3)
bottom_ref <- parseJSON (a ! 4)
filename <- parseJSON (a ! 5)
modtime <- parseJSON (a ! 6)
xref <- parseJSON (a ! 7)
return $ Unit {
mainline_ref=mainline_ref,
name=name,
setting=setting,
bottom_ref=bottom_ref,
filename=filename,
modtime=modtime,
xref=xref
}
parseJSON other = fail ("Can't parse Unit:"++(show other))
--showNode x = "...;\n"
Jump to Line
Something went wrong with that request. Please try again.