packages feed

oplang 0.4.0.1 → 0.5.0.0

raw patch · 8 files changed

+160/−76 lines, 8 filesdep ~containers

Dependency ranges changed: containers

Files

CHANGELOG.md view
@@ -1,5 +1,12 @@ <!-- markdownlint-disable first-line-h1 --> +## v0.5.0.0 \[2024-04-28\]++* Use `putchar`/`getchar` instead of `printf`/`scanf` for I/O+* Optimizer improvements+  * Can now optimize more complex loops into constant-time arithmetic+  * Performs better constant propagation+ ## v0.4.0.1 \[2023-12-28\]  * Improve error messages, warnings, and `--help` text
oplang.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0  name: oplang-version: 0.4.0.1+version: 0.5.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@@ -10,11 +10,11 @@ license-file: LICENSE.txt author: Alex Ionescu maintainer: aaionescu@pm.me-copyright: Copyright (C) 2019-2023 Alex Ionescu+copyright: Copyright (C) 2019-2024 Alex Ionescu category: Compilers/Interpreters, Language build-type: Simple -tested-with: GHC == { 9.2.8, 9.4.8, 9.6.3, 9.8.1 }+tested-with: GHC == { 9.2.8, 9.4.8, 9.6.3, 9.8.2 }  extra-doc-files:   CHANGELOG.md@@ -32,10 +32,13 @@     BlockArguments     DerivingStrategies     LambdaCase+    LexicalNegation+    NegativeLiterals     NoFieldSelectors     OverloadedRecordDot     OverloadedStrings     RecordWildCards+    ViewPatterns    other-extensions:     StrictData
src/Language/OpLang/Codegen.hs view
@@ -10,18 +10,18 @@  type CCode = Builder -cName :: Id -> CCode-cName n = "o" <> fromDec (ord n)+cName :: Name -> CCode+cName name = "_" <> fromDec (ord name)  programHeader :: Word -> Word -> CCode programHeader stackSize tapeSize =   "#include<stdio.h>\n#define T " <> fromDec tapeSize   <> "\nchar q[" <> fromDec stackSize <> "],*s=q;" -forwardDecl :: Id -> CCode+forwardDecl :: Name -> CCode forwardDecl name = "void " <> cName name <> "();" -codegenDef :: Id -> [Instr] -> CCode+codegenDef :: Name -> [Instr] -> CCode codegenDef name body = "void " <> cName name <> "(){char u[T]={0},*t=u;" <> codegenOps body <> "}"  codegenMain :: [Instr] -> CCode@@ -32,31 +32,31 @@  tape :: Offset -> CCode tape 0 = "*t"-tape off = "t[" <> fromDec off <> "]"+tape offset = "t[" <> fromDec offset <> "]"  plusEq :: (Ord a, Num a) => a -> CCode-plusEq n-  | n < 0 = "-="+plusEq val+  | val < 0 = "-="   | otherwise = "+=" -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+times :: Val -> CCode+times 1 = ""+times n = "*" <> fromDec n  codegenOp :: Instr -> CCode codegenOp = \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'+  Add offset val -> tape offset <> plusEq val <> fromDec (abs val) <> ";"+  Set offset val -> tape offset <> "=" <> fromDec val <> ";"+  Pop offset -> tape offset <> "=*(--s);"+  Push offset -> "*(s++)=" <> tape offset <> ";"+  PushKnown val -> "*(s++)=" <> fromDec val <> ";"+  Read offset -> tape offset <> "=getchar();"+  Write offset -> "putchar(" <> tape offset <> ");"+  WriteKnown val -> "putchar(" <> fromDec val <> ");"+  Move offset -> "t" <> plusEq offset <> fromDec (abs offset) <> ";"+  AddMul offset initialOffset val -> tape offset <> plusEq val <> tape initialOffset <> times (abs val) <> ";"   Loop ops -> "while(*t){" <> codegenOps ops <> "}"-  Call c -> cName c <> "();"+  Call name -> cName name <> "();"  codegen :: Word -> Word -> Program Instr -> Text codegen stackSize tapeSize Program{..} =
src/Language/OpLang/Optimizer.hs view
@@ -1,56 +1,128 @@ module Language.OpLang.Optimizer(optimize) where +import Data.IntMap.Strict(IntMap)+import Data.IntMap.Strict qualified as I+import Data.IntSet qualified as S+ import Language.OpLang.Syntax -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+-- Models partial information about a memory cell, used during partial evaluation.+data Cell+  = UnknownPlus Val -- Unknown starting value + a known constant.+  | Known Bool Val -- Fully-known constant value. The 'Bool' tracks whether it should be committed unconditionally.+  deriving stock Eq -syncOffset :: Offset -> [Instr] -> [Instr]-syncOffset 0 acc = acc-syncOffset n acc = Move n : acc+isKnown :: Cell -> Bool+isKnown UnknownPlus{} = False+isKnown _ = True -syncAll :: Bool -> Val -> Offset -> [Instr] -> [Instr]-syncAll known tally offset = syncTally known tally 0 . syncOffset offset+getVal :: Cell -> Val+getVal (UnknownPlus val) = val+getVal (Known _ val) = val -removeSet0 :: [Instr] -> [Instr]-removeSet0 (Set 0 0 : ops) = ops-removeSet0 ops = ops+-- 'isKnown' and 'getVal' could be made into lenses, which would make this definition redundant,+-- but adding a dependency on 'lens' just for this would be overkill.+mapVal :: (Val -> Val) -> Cell -> Cell+mapVal f (UnknownPlus val) = UnknownPlus $ f val+mapVal f (Known c val) = Known c $ f val -optimizeOps :: [Op] -> [Instr]-optimizeOps = removeSet0 . go False True 0 0 []+instance Semigroup Cell where+  (<>) :: Cell -> Cell -> Cell+  UnknownPlus a <> UnknownPlus b = UnknownPlus (a + b)+  UnknownPlus a <> Known c b = Known c (a + b)+  Known c a <> _ = Known c a++instance Monoid Cell where+  mempty :: Cell+  mempty = UnknownPlus 0++-- Models partial information about a segment of the memory tape.+-- Represented as a mapping from memory offsets to Cells.+type Tape = IntMap Cell++-- Commit a cell update instruction.+commitCell :: Offset -> Cell -> [Instr] -> [Instr]+commitCell offset cell acc =+  case cell of+    UnknownPlus 0 -> acc+    UnknownPlus val -> Add offset val : acc++    Known False 0 -> acc+    Known _ val -> Set offset val : acc++-- Commit a Move instruction.+commitMove :: Offset -> [Instr] -> [Instr]+commitMove 0 acc = acc+commitMove offset acc = Move offset : acc++-- Commit cell update instructions for all the cells in the specified tape segment.+commitCells :: Tape -> [Instr] -> [Instr]+commitCells tape acc = I.foldrWithKey' commitCell acc tape++-- Commit a set of AddMul instructions, resulting from a for-like loop.+commitAddMuls :: Offset -> Val -> IntMap Val -> [Instr] -> [Instr]+commitAddMuls offset diff vals acc = I.foldrWithKey' (commitAddMul offset diff) acc vals   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+    commitAddMul :: Offset -> Val -> Offset -> Val -> [Instr] -> [Instr]+    commitAddMul _ _ _ 0 acc = acc+    commitAddMul initialOffset diff offset val acc = AddMul offset initialOffset (val * -diff) : acc -        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+-- Partially evaluate a program, producing an optimized sequence of instructions.+pEval :: Offset -> Tape -> [Instr] -> [Op] -> (Offset, Tape, [Instr])+pEval offset tape acc [] = (offset, tape, acc)+pEval offset tape acc (op : ops) =+  case op of+    Incr -> pEval offset (I.insertWith (<>) offset (UnknownPlus 1) tape) acc ops+    Decr -> pEval offset (I.insertWith (<>) offset (UnknownPlus -1) tape) 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 n 0] | abs n == 1 -> go loop True 0 offset acc ops-            [Add n o] | abs n == 1 -> go loop known tally offset (Set 0 (offset + o) : acc) ops+    Read' -> pEval offset (I.delete offset tape) (Read offset : acc) ops+    Pop' -> pEval offset (I.delete offset tape) (Pop offset : acc) ops -            [Add n o, Add m 0] | abs m == 1 -> go loop False 0 offset (AddCell n (o + offset) offset : syncTally known tally offset acc) ops-            [Add m 0, Add n o] | abs m == 1 -> go loop False 0 offset (AddCell n (o + offset) offset : syncTally known tally offset acc) ops+    MoveL -> pEval (offset - 1) tape acc ops+    MoveR -> pEval (offset + 1) tape acc ops -            l' -> go loop False 0 0 (Loop l' : syncAll known tally offset acc) ops+    Write' ->+      case I.findWithDefault mempty offset tape of+        Known _ val -> pEval offset tape (WriteKnown val : acc) ops+        cell -> pEval offset (I.delete offset tape) (Write offset : commitCell offset cell acc) ops -optimize :: Program Op -> Program Instr-optimize Program{..} =+    Push' ->+      case I.findWithDefault mempty offset tape of+        Known _ val -> pEval offset tape (PushKnown val : acc) ops+        cell -> pEval offset (I.delete offset tape) (Push offset : commitCell offset cell acc) ops++    Call' c -> pEval offset tape (Call c : acc) ops++    Loop' l ->+      case I.findWithDefault mempty offset tape of+        Known _ 0 -> pEval offset tape acc ops++        cell ->+          case pEval 0 I.empty [] l of+            (0, I.mapKeys (offset +) -> tape', []) | Just (UnknownPlus diff) <- tape' I.!? offset, abs diff == 1, not $ any isKnown tape' ->+              case cell of+                Known _ val -> pEval offset (I.insert offset (Known True 0) $ I.unionWith (<>) (mapVal ((val * -diff) *) <$> tape') tape) acc ops+                _ ->+                  let+                    modified = I.intersection tape tape'+                    addMuls = getVal <$> I.delete offset tape'+                    remaining = tape I.\\ modified+                  in+                    pEval offset (I.insert offset (Known True 0) remaining) (commitAddMuls offset diff addMuls $ commitCells modified acc) ops++            (offset', tape', acc') ->+              let l' = Loop $ reverse $ commitMove offset' $ commitCells tape' acc'+              in pEval 0 (I.singleton 0 $ Known False 0) (l' : commitMove offset (commitCells tape acc)) ops++optimizeOps :: Word -> [Op] -> [Instr]+optimizeOps tapeSize ops = reverse acc+  where+    initialTape = I.fromSet (const $ Known False 0) $ S.fromRange (0, fromEnum tapeSize - 1)+    (_, _, acc) = pEval 0 initialTape [] ops++optimize :: Word -> Program Op -> Program Instr+optimize tapeSize Program{..} =   Program-  { opDefs = optimizeOps <$> opDefs-  , topLevel = optimizeOps topLevel+  { opDefs = optimizeOps tapeSize <$> opDefs+  , topLevel = optimizeOps tapeSize topLevel   }
src/Language/OpLang/Parser.hs view
@@ -59,10 +59,10 @@   , Call' <$> custom   ] <?> "operator" -def :: Parser (Id, [Op])+def :: Parser (Name, [Op]) def = (,) <$> custom <*> block "{" "}" <?> "definition" -defs :: Parser (Map Id [Op])+defs :: Parser (Map Name [Op]) defs = many (try def) >>= toMap   where     toMap ds
src/Language/OpLang/Syntax.hs view
@@ -4,7 +4,7 @@ import Data.Int(Int8) import Data.Map.Strict(Map) -type Id = Char+type Name = Char type Val = Int8 type Offset = Int @@ -19,26 +19,28 @@   | Pop'   | Push'   | Loop' [Op]-  | Call' Id+  | Call' Name   deriving stock Show  -- Internal IR, used for optimizations and codegen data Instr-  = Add Val Offset-  | Set Val Offset+  = Add Offset Val+  | Set Offset Val   | Read Offset   | Write Offset+  | WriteKnown Val   | Pop Offset   | Push Offset+  | PushKnown Val   | Move Offset   | Loop [Instr]-  | Call Id-  | AddCell Val Offset Offset+  | Call Name+  | AddMul Offset Offset Val   deriving stock Show  data Program op   = Program-  { opDefs :: Map Id [op]+  { opDefs :: Map Name [op]   , topLevel :: [op]   }   deriving stock Show
src/Language/OpLang/Validation.hs view
@@ -15,7 +15,7 @@  import Language.OpLang.Syntax -calledOps :: [Op] -> Set Id+calledOps :: [Op] -> Set Name calledOps = foldMap' \case   Call' op -> S.singleton op   Loop' ops -> calledOps ops@@ -34,7 +34,7 @@     toMsgs (name, ops) = S.toList ops <&> \op ->       "Error: In " <> fmt name <> ": Call to undefined operator " <> T.pack (show op) <> "." -allUsedOps :: Map Id [Op] -> Set Id -> [Op] -> Set Id+allUsedOps :: Map Name [Op] -> Set Name -> [Op] -> Set Name allUsedOps defs seen ops   | S.null used = seen   | otherwise = foldMap' ((allUsedOps defs (seen <> used)) . fromMaybe [] . (defs M.!?)) used
src/Main.hs view
@@ -53,7 +53,7 @@    ast' <- validate opts.noWarn ast -  let ir = optimize ast'+  let ir = optimize opts.tapeSize ast'   when opts.dumpIR do     lift $ putStrLn $ "IR:\n" <> show ir <> "\n"