packages feed

oplang 0.2.0.0 → 0.3.0.0

raw patch · 17 files changed

+444/−454 lines, 17 filesdep +text-builder-lineardep −text-builderdep ~containersdep ~directorydep ~mtl

Dependencies added: text-builder-linear

Dependencies removed: text-builder

Dependency ranges changed: containers, directory, mtl, optparse-applicative, process, text, transformers

Files

CHANGELOG.md view
@@ -1,9 +1,17 @@-## v0.2.0.0 [2022-03-19]+## v0.3.0.0 \[2022-08-12\] +* Upgrade to [`text`](https://hackage.haskell.org/package/text) v2 and use [`text-builder-linear`](https://hackage.haskell.org/package/text-builder-linear), improving compilation performance+* Optimizer overhaul+  * Now uses a separate IR+  * Performs more optimizations, runs in a single pass+  * Generates smaller and slightly faster C code++## v0.2.0.0 \[2022-03-19\]+ * Parser error message improvements * Codegen improvements-* **[Breaking]** Tailcalls are no longer optimized+* **\[Breaking\]** Tailcalls are no longer optimized -## v0.1.0.0 [2020-10-10]+## v0.1.0.0 \[2020-10-10\]  * Initial release
README.md view
@@ -6,7 +6,7 @@  ## Installing -The compiler is available on [Hackage](https://hackage.haskell.org/package/oplang), and can be installed via [`cabal`](https://www.haskell.org/cabal/).+The compiler is available on [Hackage](https://hackage.haskell.org/package/oplang), and can be installed via [cabal](https://www.haskell.org/cabal/) (which can itself be installed via [ghcup](https://www.haskell.org/ghcup/)).  ```sh cabal install oplang@@ -80,7 +80,7 @@ ,: a ;. ``` -For more example programs, see the [Examples](Examples/) folder.+For more example programs, see the [examples](examples/) folder.  ## License
oplang.cabal view
@@ -1,8 +1,8 @@ cabal-version: 3.0  name: oplang-version: 0.2.0.0-synopsis: Compiler for OpLang, an esoteric programming language+version: 0.3.0.0+synopsis: Stack-based esoteric programming language description: Please see the README on GitHub at <https://github.com/aionescu/oplang#readme> homepage: https://github.com/aionescu/oplang#readme bug-reports: https://github.com/aionescu/oplang/issues@@ -11,7 +11,7 @@ author: Alex Ionescu maintainer: alxi.2001@gmail.com copyright: Copyright (C) 2019-2022 Alex Ionescu-category: Compiler+category: Compilers/Interpreters, Language build-type: Simple  extra-source-files:@@ -26,38 +26,45 @@   main-is: Main.hs    other-modules:-    Control.Monad.Comp-    Data.Opts-    Language.OpLang.Checker     Language.OpLang.Codegen-    Language.OpLang.Optimizer-    Language.OpLang.Parser-    Language.OpLang.Syntax+    Language.OpLang.CompT+    Language.OpLang.IR+    Language.OpLang.Optimize+    Language.OpLang.Parse+    Language.OpLang.Validate+    Opts    hs-source-dirs: src    build-depends:     base >=4.14 && <5-    , containers ^>= 0.6.2-    , directory ^>= 1.3.6+    , containers ^>= 0.6.5+    , directory ^>= 1.3.7     , filepath ^>= 1.4.2     , megaparsec ^>= 9.2-    , mtl ^>= 2.2.2-    , optparse-applicative ^>= 0.16-    , process ^>= 1.6.9-    , text ^>= 1.2.4-    , text-builder ^>= 0.6.6-    , transformers ^>= 0.5.6+    , mtl ^>= 2.3+    , optparse-applicative ^>= 0.17+    , process ^>= 1.6.14+    , text ^>= 2+    , text-builder-linear ^>= 0.1+    , transformers ^>= 0.6    ghc-options:     -threaded     -rtsopts     -with-rtsopts=-N     -Wall+    -Wcompat     -Wincomplete-uni-patterns     -Wprepositive-qualified-module     -Wmissing-deriving-strategies     -Wunused-packages+    -Widentities+    -Wredundant-constraints+    -Wunticked-promoted-constructors+    -Wpartial-fields+    -Wmissing-exported-signatures+    -Wno-name-shadowing    default-extensions:     ApplicativeDo@@ -73,6 +80,7 @@     DeriveLift     DeriveTraversable     DerivingStrategies+    DerivingVia     EmptyCase     ExistentialQuantification     FlexibleContexts@@ -84,10 +92,15 @@     InstanceSigs     KindSignatures     LambdaCase+    MagicHash     MultiParamTypeClasses     MultiWayIf     NamedFieldPuns+    NegativeLiterals+    NoMonomorphismRestriction+    NoStarIsType     OverloadedStrings+    PartialTypeSignatures     PatternSynonyms     RankNTypes     RecordWildCards@@ -99,6 +112,8 @@     TypeFamilies     TypeFamilyDependencies     TypeOperators+    UnboxedTuples+    UndecidableInstances     ViewPatterns    default-language: Haskell2010
− src/Control/Monad/Comp.hs 
@@ -1,34 +0,0 @@-module Control.Monad.Comp(Comp, runComp) where--import Control.Applicative(Alternative)-import Control.Category((>>>))-import Control.Monad(MonadPlus)-import Control.Monad.IO.Class(MonadIO)-import Control.Monad.Reader(MonadReader, ReaderT, runReaderT)-import Control.Monad.Trans.Maybe(MaybeT (runMaybeT))-import Control.Monad.Writer.Strict(MonadWriter, WriterT, runWriterT)-import Data.Text(Text)-import Data.Tuple(swap)--import Data.Opts(Opts)--newtype Comp a =-  Comp { runComp' :: ReaderT Opts (MaybeT (WriterT [Text] IO)) a }-  deriving newtype-    ( Functor-    , Applicative-    , Alternative-    , Monad-    , MonadPlus-    , MonadReader Opts-    , MonadWriter [Text]-    , MonadIO-    )--runComp :: Opts -> Comp a -> IO ([Text], Maybe a)-runComp opts =-  runComp'-  >>> flip runReaderT opts-  >>> runMaybeT-  >>> runWriterT-  >>> fmap swap
− src/Data/Opts.hs 
@@ -1,53 +0,0 @@-module Data.Opts(Opts(..), getOpts) where--import Options.Applicative-import System.FilePath(dropExtension)-import System.Info(os)--data Opts =-  Opts-  { optsOptPasses :: !Word-  , optsStackSize :: !Word-  , optsTapeSize :: !Word-  , optsKeepCFile :: !Bool-  , optsCCPath :: !FilePath-  , optsOutPath :: !FilePath-  , optsPath :: !FilePath-  }--optsParser :: ParserInfo Opts-optsParser =-  info-    (infoOption "oplang v0.2.0.0" (short 'v' <> long "version" <> help "Shows version information.")-      <*> helper-      <*> programOptions)-    (fullDesc-      <> progDesc "Compiles an OpLang source file to a native executable."-      <> header "oplang - The OpLang Compiler")--  where-    programOptions :: Parser Opts-    programOptions =-      Opts-      <$> option auto (short 'O' <> long "opt-passes" <> metavar "PASSES" <> value 64 <> help "Specify the number of optimization passes to perform.")-      <*> option auto (short 'S' <> long "stack-size" <> metavar "STACK" <> value 4096 <> help "Specify the size of the stack.")-      <*> option auto (short 'T' <> long "tape-size" <> metavar "TAPE" <> value 65536 <> help "Specify the size of the memory tape.")-      <*> switch (short 'K' <> long "keep-c-file" <> help "Specifiy whether to keep the resulting C file.")-      <*> strOption (short 'C' <> long "cc-path" <> metavar "CC_PATH" <> value "cc" <> help "Specify the path of the C compiler to use.")-      <*> strOption (short 'o' <> long "out-path" <> metavar "OUT_PATH" <> value "" <> help "Specify the path of the resulting executable.")-      <*> strArgument (metavar "PATH" <> help "The source file to compile.")--withExt :: FilePath -> FilePath-withExt path = dropExtension path <> ext os-  where-    ext "mingw32" = ".exe"-    ext _ = ".out"--setOutPath :: Opts -> Opts-setOutPath opts =-  case optsOutPath opts of-    "" -> opts { optsOutPath = withExt $ optsPath opts }-    _ -> opts--getOpts :: IO Opts-getOpts = setOutPath <$> execParser optsParser
− src/Language/OpLang/Checker.hs 
@@ -1,56 +0,0 @@-module Language.OpLang.Checker(check) where--import Control.Monad(guard)-import Control.Monad.Writer.Strict(tell)-import Data.Bifunctor(bimap)-import Data.Functor(($>))-import Data.List(intercalate)-import Data.Map.Strict(Map)-import Data.Map.Strict qualified as M-import Data.Set(Set)-import Data.Set qualified as S-import Data.Text(Text)-import Data.Text qualified as T--import Control.Monad.Comp(Comp)-import Language.OpLang.Syntax(Program(..), Op, Id, calledOps)--enumerate :: Show a => [a] -> Text-enumerate l = T.pack $ intercalate ", " $ show <$> l--checkUndefinedCalls :: Program -> Comp ()-checkUndefinedCalls Program{..} = tell errors *> guard (null errors)-  where-    defined = M.keysSet opDefs--    undefinedInTopLevel = (Nothing, calledOps topLevel S.\\ defined)-    undefinedInDefs = bimap Just ((S.\\ defined) . calledOps) <$> M.toList opDefs--    fmt = maybe "top level" $ ("definition of " <>) . T.pack . show-    toMsg (name, ops) =-      "Error (in " <> fmt name <> "): Calls to undefined operators: " <> enumerate (S.toList ops)--    errors = toMsg <$> filter (not . S.null . snd) (undefinedInTopLevel : undefinedInDefs)--allUsedOps :: Map Id [Op] -> Set Id -> [Op] -> Set Id-allUsedOps defs seen ops-  | S.null used = seen-  | otherwise = foldMap (allUsedOps defs (seen <> used) . (defs M.!)) used-  where-    used = calledOps ops S.\\ seen--removeUnusedOps :: Program -> Comp Program-removeUnusedOps p@Program{..} =-  tell warning $> p { opDefs = usedDefs }-  where-    warning =-      [ "Warning: Unused operators: " <> enumerate (M.keys unusedDefs)-      | not $ M.null unusedDefs-      ]--    unusedDefs = opDefs M.\\ usedDefs-    usedDefs = M.restrictKeys opDefs usedOps-    usedOps = allUsedOps opDefs S.empty topLevel--check :: Program -> Comp Program-check p = checkUndefinedCalls p *> removeUnusedOps p
src/Language/OpLang/Codegen.hs view
@@ -1,96 +1,98 @@ module Language.OpLang.Codegen(compile) where  import Control.Monad(unless)-import Control.Monad.IO.Class(liftIO) import Control.Monad.Reader(ask)+import Control.Monad.Trans(lift) import Data.Char(ord)-import Data.Foldable(fold)+import Data.Foldable(foldMap') import Data.Map.Strict qualified as M+import Data.Maybe(fromMaybe) import Data.Text(Text)-import Data.Text qualified as T+import Data.Text.Builder.Linear(Builder, fromDec, runBuilder) import Data.Text.IO qualified as T-import Numeric(showHex)-import System.Directory(removeFile)-import System.FilePath(dropExtension)+import System.Directory(createDirectoryIfMissing, removeFile)+import System.FilePath(dropExtension, takeDirectory)+import System.Info(os) import System.Process(system)-import Text.Builder(Builder)-import Text.Builder qualified as B -import Control.Monad.Comp(Comp)-import Data.Opts(Opts(..))-import Language.OpLang.Syntax(Id, Op(..), Program(..))+import Language.OpLang.CompT(CompT)+import Language.OpLang.IR+import Opts(Opts(..))  type CCode = Builder -showC :: Show a => a -> CCode-showC = B.string . show- cName :: Id -> CCode-cName n = "o" <> B.string (showHex (ord n) "")+cName n = "o" <> fromDec (ord n) -programPrologue :: Word -> Word -> CCode-programPrologue stackSize tapeSize =-  "#include<stdio.h>\n#include<string.h>\n#define S "-  <> showC stackSize-  <> "\n#define T "-  <> showC tapeSize-  <> "\nchar s_[S],*s=s_;"+programHeader :: Word -> Word -> CCode+programHeader stackSize tapeSize =+  "#include<stdio.h>\n#define T " <> fromDec tapeSize+  <> "\nchar q[" <> fromDec stackSize <> "],*s=q;" -compileProto :: Id -> CCode-compileProto name = "void " <> cName name <> "();"+forwardDecl :: Id -> CCode+forwardDecl name = "void " <> cName name <> "();" -compileDef :: Id -> [Op] -> CCode-compileDef name body = "void " <> cName name <> "(){char t_[T],*t=t_;memset(t,0,T);" <> compileOps body <> "}"+compileDef :: Id -> [Instr] -> CCode+compileDef name body = "void " <> cName name <> "(){char u[T]={0},*t=u;" <> compileOps body <> "}" -compileMain :: [Op] -> CCode-compileMain body = "int main(){char t_[T],*t=t_;memset(t,0,T);" <> compileOps body <> "return 0;}"+compileMain :: [Instr] -> CCode+compileMain body = "int main(){char u[T]={0},*t=u;" <> compileOps body <> "return 0;}" -compileOps :: [Op] -> CCode-compileOps = foldMap $ compileOp "t"+compileOps :: [Instr] -> CCode+compileOps = foldMap' compileOp -sign :: (Ord a, Num a) => a -> CCode-sign n-  | n < 0 = "-"-  | otherwise = "+"+tape :: Offset -> CCode+tape 0 = "*t"+tape off = "t[" <> fromDec off <> "]" -repeatText :: Word -> Text -> CCode-repeatText n = B.text . T.concat . replicate (fromIntegral n)+plusEq :: (Ord a, Num a) => a -> CCode+plusEq n+  | n < 0 = "-="+  | otherwise = "+=" -compileOp :: CCode -> Op -> CCode-compileOp tape = \case-  Add n -> "*" <> tape <> sign n <> "=" <> showC (abs n) <> ";"-  Move n -> tape <> sign n <> "=" <> showC (abs n) <> ";"-  Set n -> "*" <> tape <> "=" <> showC n <> ";"-  Pop n -> "*" <> tape <> "=*(s-=" <> showC n <> ");"-  Push -> "*(s++)=*" <> tape <> ";"-  Peek -> "*" <> tape <> "=*(s-1);"-  WithOffset off op -> compileOp ("(" <> tape <> "+" <> showC off <> ")") op-  Loop ops -> "while(*t){" <> compileOps ops <> "}"-  Read -> "scanf(\"%c\"," <> tape <> ");"-  Write 1 -> "printf(\"%c\",*" <> tape <> ");"-  Write n -> "{char c=*" <> tape <> ";printf(\"" <> repeatText n "%c" <> "\"" <> repeatText n ",c" <> ");}"-  Call c -> cName c <> "();"+addCell :: Val -> Offset -> Offset -> CCode+addCell v o o' = tape o <> plusEq v <> tape o' <> times (abs v) <> ";" <> tape o' <> "=0;"+  where+    times 1 = ""+    times n = "*" <> fromDec n -codegen :: Word -> Word -> Program -> Text+compileOp :: Instr -> CCode+compileOp = \case+    Add n o -> tape o <> plusEq n <> fromDec (abs n) <> ";"+    Set n o -> tape o <> "=" <> fromDec n <> ";"+    Pop o -> tape o <> "=*(--s);"+    Push o -> "*(s++)=" <> tape o <> ";"+    Read o -> "scanf(\"%c\",&" <> tape o <> ");"+    Write o -> "printf(\"%c\"," <> tape o <> ");"+    Move n -> "t" <> plusEq n <> fromDec (abs n) <> ";"+    AddCell n o o' -> addCell n o o'+    Loop ops -> "while(*t){" <> compileOps ops <> "}"+    Call c -> cName c <> "();"++codegen :: Word -> Word -> Program Instr -> Text codegen stackSize tapeSize Program{..} =-  B.run-  $ programPrologue stackSize tapeSize-  <> fold (compileProto <$> M.keys opDefs)-  <> fold (M.mapWithKey compileDef opDefs)+  runBuilder+  $ programHeader stackSize tapeSize+  <> foldMap' forwardDecl (M.keys opDefs)+  <> M.foldMapWithKey compileDef opDefs   <> compileMain topLevel -cFile :: FilePath -> FilePath-cFile file = dropExtension file <> ".c"+exePath :: FilePath -> FilePath+exePath path = dropExtension path <> ext os+  where+    ext "mingw32" = ".exe"+    ext _ = "" -compile :: Program -> Comp ()+compile :: Program Instr -> CompT IO () compile p = do   Opts{..} <- ask-  let cPath = cFile optsPath-  let code = codegen optsStackSize optsTapeSize p+  let cFile = dropExtension optsPath <> ".c"+  let cCode = codegen optsStackSize optsTapeSize p+  let outFile = fromMaybe (exePath optsPath) optsOutPath -  liftIO do-    T.writeFile cPath code-    system $ show optsCCPath <> " -o " <> show optsOutPath <> " " <> show cPath+  lift do+    T.writeFile cFile cCode+    createDirectoryIfMissing True $ takeDirectory outFile -    unless optsKeepCFile $-      removeFile cPath+    system $ show optsCCPath <> " -o " <> show outFile <> " " <> show cFile+    unless optsKeepCFile $ removeFile cFile
+ src/Language/OpLang/CompT.hs view
@@ -0,0 +1,31 @@+module Language.OpLang.CompT(CompT(..)) where++import Control.Applicative(Alternative)+import Control.Monad(MonadPlus)+import Control.Monad.IO.Class(MonadIO)+import Control.Monad.Reader(MonadReader, ReaderT(..))+import Control.Monad.Trans(MonadTrans(..))+import Control.Monad.Trans.Maybe(MaybeT(..))+import Control.Monad.Writer.Strict(MonadWriter, WriterT(..))+import Data.Coerce(coerce)+import Data.Text(Text)++import Opts(Opts)++-- The "Compilation" Monad Transformer+newtype CompT m a =+  CompT { runCompT :: Opts -> m (Maybe a, [Text]) }+  deriving+    ( Functor+    , Applicative+    , Alternative+    , Monad+    , MonadPlus+    , MonadReader Opts+    , MonadWriter [Text]+    , MonadIO+    )+    via ReaderT Opts (MaybeT (WriterT [Text] m))++instance MonadTrans CompT where+  lift = coerce . lift @(ReaderT Opts) . lift @MaybeT . lift @(WriterT [Text])
+ src/Language/OpLang/IR.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE StrictData #-}++module Language.OpLang.IR where++import Data.Int(Int8)+import Data.Map.Strict(Map)++type Id = Char+type Val = Int8+type Offset = Int++-- "Surface-level" AST, produced by the parser+data Op+  = Incr+  | Decr+  | MoveL+  | MoveR+  | Read'+  | Write'+  | Pop'+  | Push'+  | Loop' [Op]+  | Call' Id++-- Internal AST, used for optimizations and codegen+data Instr+  = Add Val Offset+  | Set Val Offset+  | Read Offset+  | Write Offset+  | Pop Offset+  | Push Offset+  | Move Offset+  | Loop [Instr]+  | Call Id+  | AddCell Val Offset Offset++data Program op+  = Program+  { opDefs :: Map Id [op]+  , topLevel :: [op]+  }
+ src/Language/OpLang/Optimize.hs view
@@ -0,0 +1,59 @@+module Language.OpLang.Optimize(optimize) where++import Language.OpLang.IR++syncTally :: Bool -> Val -> Offset -> [Instr] -> [Instr]+syncTally False 0 _ acc = acc+syncTally False n offset acc = Add n offset : acc+syncTally True n offset acc = Set n offset : acc++syncOffset :: Offset -> [Instr] -> [Instr]+syncOffset 0 acc = acc+syncOffset n acc = Move n : acc++syncAll :: Bool -> Val -> Offset -> [Instr] -> [Instr]+syncAll known tally offset = syncTally known tally 0 . syncOffset offset++removeSet0 :: [Instr] -> [Instr]+removeSet0 (Set 0 0 : ops) = ops+removeSet0 ops = ops++optimizeOps :: [Op] -> [Instr]+optimizeOps = removeSet0 . go False True 0 0 []+  where+    go :: Bool -> Bool -> Val -> Offset -> [Instr] -> [Op] -> [Instr]+    go False _ _ _ acc [] = reverse acc+    go True known tally offset acc [] = reverse $ syncAll known tally offset acc+    go loop known tally offset acc (op : ops) =+      case op of+        Incr -> go loop known (tally + 1) offset acc ops+        Decr -> go loop known (tally - 1) offset acc ops+        Read' -> go loop False 0 offset (Read offset : acc) ops+        Pop' -> go loop False 0 offset (Pop offset : acc) ops++        MoveL -> go loop False 0 (offset - 1) (syncTally known tally offset acc) ops+        MoveR -> go loop False 0 (offset + 1) (syncTally known tally offset acc) ops+        Write' -> go loop False 0 offset (Write offset : syncTally known tally offset acc) ops+        Push' -> go loop False 0 offset (Push offset : syncTally known tally offset acc) ops+        Call' c -> go loop False 0 offset (Call c : syncTally known tally offset acc) ops++        Loop' _ | (True, 0) <- (known, tally) -> go loop known tally offset acc ops+        Loop' l ->+          case go True False 0 0 [] l of+            [Add 1 0] -> go loop True 0 offset acc ops+            [Add -1 0] -> go loop True 0 offset acc ops++            [Add 1 o] -> go loop known tally offset (Set 0 (offset + o) : acc) ops+            [Add -1 o] -> go loop known tally offset (Set 0 (offset + o) : acc) ops++            [Add n o, Add -1 0] -> go loop False 0 offset (AddCell n (o + offset) offset : syncTally known tally offset acc) ops+            [Add -1 0, Add n o] -> go loop False 0 offset (AddCell n (o + offset) offset : syncTally known tally offset acc) ops++            l' -> go loop False 0 0 (Loop l' : syncAll known tally offset acc) ops++optimize :: Program Op -> Program Instr+optimize Program{..} =+  Program+  { opDefs = optimizeOps <$> opDefs+  , topLevel = optimizeOps topLevel+  }
− src/Language/OpLang/Optimizer.hs 
@@ -1,84 +0,0 @@-module Language.OpLang.Optimizer(optimize) where--import Control.Category((>>>))-import Control.Monad.Reader(asks)--import Control.Monad.Comp(Comp)-import Data.Opts(Opts(..))-import Language.OpLang.Syntax(Program(..), Op(..))--canDoWithOffset :: Op -> Bool-canDoWithOffset (Move _) = False-canDoWithOffset (Loop _) = False-canDoWithOffset (Call _) = False-canDoWithOffset _ = True--optimizeOnce :: [Op] -> (Bool, [Op])-optimizeOnce = go False []-  where-    go :: Bool -> [Op] -> [Op] -> (Bool, [Op])-    go changed acc ops' =-      case ops' of-        Add 0 : ops -> go True acc ops-        Move 0 : ops -> go True acc ops-        Pop 0 : ops -> go True acc ops--        Loop [Add (-1)] : ops -> go True acc (Set 0 : ops)-        Loop [Add 1] : ops -> go True acc (Set 0 : ops)--        Set s : Add a : ops -> go True acc (Set (s + a) : ops)-        Add a : Add b : ops -> go True acc (Add (a + b) : ops)-        Move a : Move b : ops -> go True acc (Move (a + b) : ops)-        Pop a : Pop b : ops -> go True acc (Pop (a + b) : ops)-        Write a : Write b : ops -> go True acc (Write (a + b) : ops)--        Add _ : ops@(Read : _) -> go True acc ops-        Add _ : ops@(Pop _ : _) -> go True acc ops-        Add _ : ops@(Set _ : _) -> go True acc ops--        Set _ : ops@(Read : _) -> go True acc ops-        Set _ : ops@(Pop _ : _) -> go True acc ops-        Set _ : ops@(Set _ : _) -> go True acc ops--        Pop n : Push : ops -> go True acc (Pop (n - 1) : Peek : ops)-        Push : Pop n : ops -> go True acc (Pop (n - 1) : ops)--        Move m : op : Move n : ops-          | canDoWithOffset op && m == -n -> case op of-              WithOffset o op' -> go True acc (WithOffset (m + o) op' : ops)-              _ -> go True acc (WithOffset m op : ops)--        Set 0 : Loop _ : ops -> go True acc (Set 0 : ops)-        l@(Loop _) : Loop _ : ops -> go True acc (l : ops)-        Loop [l@(Loop _)] : ops -> go True acc (l : ops)-        Loop l : ops ->-          let (changed', l') = go False [] l-          in go changed' (Loop l' : acc) ops--        op : ops -> go changed (op : acc) ops-        [] -> (changed, reverse acc)--optimizeN :: Word -> [Op] -> [Op]-optimizeN 0 ops = ops-optimizeN n ops =-  if changed-  then optimizeN (n - 1) ops'-  else ops'--  where-    (changed, ops') = optimizeOnce ops--removeSet0 :: [Op] -> [Op]-removeSet0 (Set 0 : ops) = ops-removeSet0 ops = ops--optimizeOps :: Word -> [Op] -> [Op]-optimizeOps passes ops = removeSet0 $ optimizeN passes (Set 0 : ops)--optimize :: Program -> Comp Program-optimize Program{..} =-  asks $ optsOptPasses >>> \passes ->-    Program-    { opDefs = optimizeOps passes <$> opDefs-    , topLevel = optimizeOps passes topLevel-    }
+ src/Language/OpLang/Parse.hs view
@@ -0,0 +1,86 @@+module Language.OpLang.Parse(parse) where++import Control.Monad.Reader(asks)+import Control.Monad.Writer.Strict(tell)+import Data.Functor(($>))+import Data.List(intercalate)+import Data.Map.Strict(Map)+import Data.Map.Strict qualified as M+import Data.Set qualified as S+import Data.Text(Text)+import Data.Text qualified as T+import Data.Void(Void)+import Text.Megaparsec hiding (parse)+import Text.Megaparsec.Char(space1)+import Text.Megaparsec.Char.Lexer qualified as L++import Language.OpLang.CompT(CompT)+import Language.OpLang.IR(Program(..), Op(..), Id)+import Opts(Opts(..))++type Parser = Parsec Void Text++ws :: Parser ()+ws = L.space space1 (L.skipLineComment "#") empty++lexeme :: Parser a -> Parser a+lexeme = L.lexeme ws++symbol :: Text -> Parser Text+symbol = L.symbol ws++reserved :: [Char]+reserved = "+-<>,.;:[]{}"++intrinsic :: Parser Op+intrinsic =+  choice+  [ symbol "+" $> Incr+  , symbol "-" $> Decr+  , symbol "<" $> MoveL+  , symbol ">" $> MoveR+  , symbol "," $> Read'+  , symbol "." $> Write'+  , symbol ";" $> Pop'+  , symbol ":" $> Push'+  ]+  <?> "intrinsic operator"++block :: Text -> Text -> Parser [Op]+block b e = between (symbol b) (symbol e) $ many op++loop :: Parser Op+loop = Loop' <$> block "[" "]" <?> "loop"++custom :: Parser Char+custom = lexeme (satisfy (`notElem` reserved) <?> "custom operator")++op :: Parser Op+op = choice [loop, intrinsic, Call' <$> custom] <?> "operator"++def :: Parser (Id, [Op])+def = (,) <$> lexeme custom <*> block "{" "}" <?> "definition"++defs :: Parser (Map Id [Op])+defs = many (try def) >>= toMap+  where+    toMap ds+      | unique = pure $ M.fromList ds+      | otherwise = fail $ "Duplicate definition of operators: " <> intercalate ", " (show <$> S.toList set)+      where+        ids = fst <$> ds+        set = S.fromList ids+        unique = S.size set == length ids++program :: Parser (Program Op)+program = Program <$> defs <*> (many op <?> "toplevel")++programFull :: Parser (Program Op)+programFull = ws *> program <* eof++parse :: Monad m => Text -> CompT m (Program Op)+parse code = do+  file <- asks optsPath+  case runParser programFull file code of+    Left e -> tell [T.pack $ errorBundlePretty e] *> empty+    Right p -> pure p
− src/Language/OpLang/Parser.hs 
@@ -1,87 +0,0 @@-module Language.OpLang.Parser(parse) where--import Control.Monad.Reader(asks)-import Control.Monad.Writer.Strict(tell)-import Data.Functor(($>))-import Data.List(intercalate)-import Data.Map.Strict(Map)-import Data.Map.Strict qualified as M-import Data.Set qualified as S-import Data.Text(Text)-import Data.Text qualified as T-import Data.Void(Void)-import Text.Megaparsec hiding (parse)-import Text.Megaparsec.Char(space1)-import Text.Megaparsec.Char.Lexer qualified as L--import Control.Monad.Comp(Comp)-import Data.Opts(optsPath)-import Language.OpLang.Syntax(Program(..), Op(..), Id)--type Parser = Parsec Void Text--ws :: Parser ()-ws = L.space space1 (L.skipLineComment "#") empty--lexeme :: Parser a -> Parser a-lexeme = L.lexeme ws--symbol :: Text -> Parser Text-symbol = L.symbol ws--reserved :: [Char]-reserved = "+-<>,.;:[]{}"--intrinsic :: Parser Op-intrinsic =-  choice-  [ symbol "+" $> Add 1-  , symbol "-" $> Add (-1)-  , symbol "<" $> Move (-1)-  , symbol ">" $> Move 1-  , symbol "," $> Read-  , symbol "." $> Write 1-  , symbol ";" $> Pop 1-  , symbol ":" $> Push-  ]-  <?> "intrinsic operator"--block :: Text -> Text -> Parser [Op]-block b e = between (symbol b) (symbol e) $ many op--loop :: Parser Op-loop = Loop <$> block "[" "]" <?> "loop"--custom :: Parser Char-custom = lexeme (satisfy (`notElem` reserved) <?> "custom operator")--op :: Parser Op-op = choice [try loop, intrinsic, Call <$> custom] <?> "operator"--def :: Parser (Id, [Op])-def = (,) <$> lexeme custom <*> block "{" "}" <?> "definition"--defs :: Parser (Map Id [Op])-defs = many (try def) >>= toMap-  where-    toMap ds-      | unique = pure $ M.fromList ds-      | otherwise = fail $ "Duplicate definition of operators: " <> intercalate ", " (show <$> S.toList set)-      where-        ids = fst <$> ds-        set = S.fromList ids-        unique = S.size set == length ids--program :: Parser Program-program = Program <$> defs <*> (many op <?> "toplevel")--programFull :: Parser Program-programFull = ws *> program <* eof--parse :: Text -> Comp Program-parse code = do-  file <- asks optsPath--  case runParser programFull file code of-    Left e -> tell [T.pack $ errorBundlePretty e] *> empty-    Right p -> pure p
− src/Language/OpLang/Syntax.hs 
@@ -1,33 +0,0 @@-module Language.OpLang.Syntax(Id, Op(..), Program(..), calledOps) where--import Data.Int(Int8)-import Data.Map.Strict(Map)-import Data.Set(Set)-import Data.Set qualified as S--type Id = Char--data Op-  = Add !Int8-  | Set !Int8-  | Move !Int-  | Pop !Word-  | Push-  | Peek-  | Read-  | Write !Word-  | WithOffset !Int !Op-  | Loop ![Op]-  | Call !Id--data Program-  = Program-  { opDefs :: Map Id [Op]-  , topLevel :: [Op]-  }--calledOps :: [Op] -> Set Id-calledOps = foldMap \case-  Call op -> S.singleton op-  Loop ops -> calledOps ops-  _ -> S.empty
+ src/Language/OpLang/Validate.hs view
@@ -0,0 +1,58 @@+module Language.OpLang.Validate(validate) where++import Control.Monad(guard, unless)+import Control.Monad.Writer.Strict(tell)+import Data.Bifunctor(bimap)+import Data.Functor(($>))+import Data.List(intercalate)+import Data.Map.Strict(Map)+import Data.Map.Strict qualified as M+import Data.Set(Set)+import Data.Set qualified as S+import Data.Text(Text)+import Data.Text qualified as T++import Language.OpLang.CompT(CompT)+import Language.OpLang.IR(Program(..), Op(..), Id)++calledOps :: [Op] -> Set Id+calledOps = foldMap \case+  Call' op -> S.singleton op+  Loop' ops -> calledOps ops+  _ -> S.empty++enumerate :: Show a => [a] -> Text+enumerate l = T.pack $ intercalate ", " $ show <$> l++errUndefinedCalls :: Monad m => Program Op -> CompT m ()+errUndefinedCalls Program{..} = tell errors *> guard (null errors)+  where+    defined = M.keysSet opDefs++    undefinedInTopLevel = (Nothing, calledOps topLevel S.\\ defined)+    undefinedInDefs = bimap Just ((S.\\ defined) . calledOps) <$> M.toList opDefs++    fmt = maybe "top level" $ ("definition of " <>) . T.pack . show+    toMsg (name, ops) =+      "Error (in " <> fmt name <> "): Calls to undefined operators: " <> enumerate (S.toList ops)++    errors = toMsg <$> filter (not . S.null . snd) (undefinedInTopLevel : undefinedInDefs)++allUsedOps :: Map Id [Op] -> Set Id -> [Op] -> Set Id+allUsedOps defs seen ops+  | S.null used = seen+  | otherwise = foldMap (allUsedOps defs (seen <> used) . (defs M.!)) used+  where+    used = calledOps ops S.\\ seen++warnUnusedOps :: Monad m => Program Op -> CompT m (Program Op)+warnUnusedOps p@Program{..} =+  unless (M.null unusedDefs) warn $> p { opDefs = usedDefs }+  where+    warn = tell ["Warning: Unused operators: " <> enumerate (M.keys unusedDefs)]+    unusedDefs = opDefs M.\\ usedDefs+    usedDefs = M.restrictKeys opDefs usedOps+    usedOps = allUsedOps opDefs S.empty topLevel++validate :: Monad m => Program Op -> CompT m (Program Op)+validate p = errUndefinedCalls p *> warnUnusedOps p
src/Main.hs view
@@ -1,34 +1,31 @@ module Main(main) where -import Control.Monad.IO.Class(liftIO)+import Control.Category((>>>))+import Control.Monad((>=>)) import Control.Monad.Reader(asks)+import Control.Monad.Trans(lift)+import Data.Bifoldable(bitraverse_) import Data.Foldable(traverse_) import Data.Text(Text) import Data.Text.IO qualified as T import System.Exit(exitFailure) -import Control.Monad.Comp(Comp, runComp)-import Data.Opts(getOpts, Opts(..))-import Language.OpLang.Checker(check) import Language.OpLang.Codegen(compile)-import Language.OpLang.Optimizer(optimize)-import Language.OpLang.Parser(parse)+import Language.OpLang.CompT(CompT(..))+import Language.OpLang.Optimize(optimize)+import Language.OpLang.Parse(parse)+import Language.OpLang.Validate(validate)+import Opts(Opts(..), getOpts) -getCode :: Comp Text-getCode = liftIO . T.readFile =<< asks optsPath+getCode :: CompT IO Text+getCode = lift . T.readFile =<< asks optsPath -pipeline :: Comp ()+pipeline :: CompT IO () pipeline =-  getCode-  >>= parse-  >>= check-  >>= optimize-  >>= compile+  getCode >>= (parse >=> validate >=> optimize >>> compile)  main :: IO ()-main = do-  opts <- getOpts-  (warnings, result) <- runComp opts pipeline--  traverse_ T.putStrLn warnings-  maybe exitFailure pure result+main =+  getOpts+  >>= runCompT pipeline+  >>= bitraverse_ (maybe exitFailure pure) (traverse_ T.putStrLn)
+ src/Opts.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE StrictData #-}++module Opts(Opts(..), getOpts) where++import Options.Applicative++data Opts =+  Opts+  { optsStackSize :: Word+  , optsTapeSize :: Word+  , optsKeepCFile :: Bool+  , optsCCPath :: FilePath+  , optsOutPath :: Maybe FilePath+  , optsPath :: FilePath+  }++optsParser :: ParserInfo Opts+optsParser =+  info+    (infoOption "oplang v0.3.0.0" (short 'v' <> long "version" <> help "Shows version information.")+      <*> helper+      <*> programOptions)+    (fullDesc+      <> progDesc "Compiles an OpLang source file to a native executable."+      <> header "oplang - The OpLang Compiler")++  where+    programOptions :: Parser Opts+    programOptions =+      Opts+      <$> option auto (short 'S' <> long "stack-size" <> value 4096 <> metavar "SIZE" <> help "Size of the stack.")+      <*> option auto (short 'T' <> long "tape-size" <> value 65536 <> metavar "SIZE" <> help "Size of the memory tape.")+      <*> switch (short 'K' <> long "keep-c-file" <> help "Keep the resulting C file.")+      <*> strOption (short 'C' <> long "cc-path" <> value "cc" <> metavar "PATH" <> help "Path of the C compiler to use.")+      <*> optional (strOption (short 'o' <> long "out-path" <> metavar "PATH" <> help "Path of the resulting executable."))+      <*> strArgument (metavar "PATH" <> help "The source file to compile.")++getOpts :: IO Opts+getOpts = execParser optsParser