forked from GitHub/gf-core
76 lines
2.1 KiB
Haskell
76 lines
2.1 KiB
Haskell
module GF.Compile.GenerateBC(generateByteCode) where
|
|
|
|
import GF.Grammar
|
|
import GF.Compile.Instructions
|
|
import PGF.Data
|
|
|
|
import Data.Maybe
|
|
import qualified Data.IntMap as IntMap
|
|
import qualified Data.ByteString as BSS
|
|
import qualified Data.ByteString.Lazy as BS
|
|
import Data.Binary
|
|
|
|
generateByteCode :: [(QIdent,Info)] -> ([(QIdent,Info,BCAddr)], BSS.ByteString)
|
|
generateByteCode = runGenM . mapM genFun
|
|
|
|
type BCLabel = (Int, BCAddr)
|
|
|
|
genFun (id,info@(AbsFun (Just (L _ ty)) ma pty _)) = do
|
|
l1 <- newLabel
|
|
{- emitLabel l1
|
|
emit Ins_fail
|
|
l2 <- newLabel
|
|
l3 <- newLabel
|
|
emit (Ins_switch_on_reg (1,addr l2,addr l3))
|
|
emitLabel l2
|
|
emit (Ins_try (1,addr l3))
|
|
emit (Ins_trust_ext (1,1))
|
|
emit (Ins_try_me_else (0,addr l1))
|
|
emitLabel l3
|
|
l4 <- newLabel
|
|
l5 <- newLabel
|
|
emit (Ins_switch_on_term (addr l4,addr l5,addr l1,addr l4))
|
|
emitLabel l4
|
|
emitLabel l5-}
|
|
return (id,info,addr l1)
|
|
genFun (id,info@(AbsCat (Just (L _ cont)))) = do
|
|
l1 <- newLabel
|
|
return (id,info,addr l1)
|
|
|
|
newtype GenM a = GenM {unGenM :: IntMap.IntMap BCAddr ->
|
|
IntMap.IntMap BCAddr ->
|
|
[Instruction] ->
|
|
(a,IntMap.IntMap BCAddr,[Instruction])}
|
|
|
|
instance Monad GenM where
|
|
return x = GenM (\fm cm is -> (x,cm,is))
|
|
f >>= g = GenM (\fm cm is -> case unGenM f fm cm is of
|
|
(x,cm,is) -> unGenM (g x) fm cm is)
|
|
|
|
runGenM :: GenM a -> (a, BSS.ByteString)
|
|
runGenM f =
|
|
let (x, cm, is) = unGenM f cm IntMap.empty []
|
|
in (x, BSS.concat (BS.toChunks (encode (BC (reverse is)))))
|
|
|
|
emit :: Instruction -> GenM ()
|
|
emit i = GenM (\fm cm is -> ((), cm, i:is))
|
|
|
|
newLabel :: GenM BCLabel
|
|
newLabel = GenM (\fm cm is ->
|
|
let lbl = IntMap.size cm
|
|
addr = fromMaybe (error "newLabel") (IntMap.lookup lbl fm)
|
|
in ((lbl,addr), IntMap.insert lbl 0 cm, is))
|
|
|
|
emitLabel :: BCLabel -> GenM ()
|
|
emitLabel (lbl,addr) = GenM (\fm cm is ->
|
|
((), IntMap.insert lbl (length is) cm, is))
|
|
|
|
addr :: BCLabel -> BCAddr
|
|
addr (lbl,addr) = addr
|
|
|
|
data ByteCode = BC [Instruction]
|
|
|
|
instance Binary ByteCode where
|
|
put (BC is) = mapM_ putInstruction is
|
|
get = error "get ByteCode"
|