Map and Set modules

.github/dependabot.yml

@@ -0,0 +1,6 @@
+version: 2
+updates:
+  - package-ecosystem: "github-actions"
+    directory: "/"
+    schedule:
+      interval: "weekly"

compiler/Makefile

@@ -1,24 +1,35 @@
 .PHONY: test
 
-all:
-	stack -v build $(STACK_OPTS)
+all: build install
+
+build: VERBOSITY_FLAG =
+build:
+	stack $(VERBOSITY_FLAG) build $(STACK_OPTS)
+build/verbose:
+	$(MAKE) $(MAKE_FLAGS) build VERBOSITY_FLAG="-v"
+
+install: VERBOSITY_FLAG =
+install:
+	$(MAKE) $(MAKE_FLAGS) build
 	mkdir  -p ./../bin
-	stack -v install $(STACK_OPTS) --local-bin-path ./../bin/
+	stack $(VERBOSITY_FLAG) install $(STACK_OPTS) --local-bin-path ./../bin/
+install/verbose:
+	$(MAKE) $(MAKE_FLAGS) install VERBOSITY_FLAG="-v"
 
 clean:
 	rm *.cabal
 	stack clean --full
 	rm -rf ../bin
 # If problems still persist after this, remove all GHC compilers in ~/.stack/programs/**/
 
-ghci-irtester:
-	stack ghci --main-is Troupe-compiler:exe:irtester --no-load
-
-ghci-troupec:
-	stack ghci --main-is Troupe-compiler:exe:troupec --no-load
-
 test:
 	stack test $(STACK_OPTS)
 
 parser-info:
 	stack exec happy -- -i src/Parser.y
+
+ghci/irtester:
+	stack ghci --main-is Troupe-compiler:exe:irtester --no-load
+
+ghci/troupec:
+	stack ghci --main-is Troupe-compiler:exe:troupec --no-load

compiler/app/Main.hs

@@ -21,9 +21,8 @@ import qualified Raw2Stack
 import qualified Stack2JS
 import qualified RawOpt
 -- import System.IO (isEOF)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS
 import Data.ByteString.Base64 (decode)
-import qualified Data.ByteString.Char8  as BSChar8
 import qualified Data.ByteString.Lazy.Char8 as BSLazyChar8
 import System.IO
 import System.Exit
@@ -220,7 +219,7 @@ fromStdinIR = do
     input <- BS.getLine
     if BS.isPrefixOf "!ECHO " input
     then let response = BS.drop 6 input
-          in do BSChar8.putStrLn response
+          in do BS.putStrLn response
 --                  debugOut "echo"
     else
       case decode input of
@@ -244,7 +243,7 @@ fromStdinIRJson = do
     input <- BS.getLine
     if BS.isPrefixOf "!ECHO " input
     then let response = BS.drop 6 input
-          in BSChar8.putStrLn response
+          in BS.putStrLn response
     else
       case decode input of
         Right bs ->

compiler/src/ClosureConv.hs

@@ -201,7 +201,7 @@ cpsToIR (CPS.LetSimple vname@(VN ident) st kt) = do
 cpsToIR (CPS.LetRet (CPS.Cont arg kt') kt) = do
     t  <- cpsToIR kt
     t' <- local (insVar arg) (cpsToIR kt')
-    return $ CCIR.BB [] $ Call arg t t'
+    return $ CCIR.BB [] $ StackExpand arg t t'
 cpsToIR (CPS.LetFun fdefs kt) = do 
     let vnames_orig = map (\(CPS.Fun fname _) -> fname) fdefs
     let localExt = local (insVars vnames_orig)

compiler/src/IR.hs

@@ -91,7 +91,7 @@ data IRTerminator
   -- and then execute the second BB, which can refer to this variable and
   -- where PC is reset to the level before entering the first BB.
   -- Represents a "let x = ... in ..." format.
-  | Call VarName IRBBTree IRBBTree
+  | StackExpand VarName IRBBTree IRBBTree
   deriving (Eq,Show,Generic)
 
 
@@ -147,7 +147,7 @@ instance ComputesDependencies IRBBTree where
 instance ComputesDependencies IRTerminator where 
     dependencies (If _ bb1 bb2) = mapM_ dependencies [bb1, bb2]
     dependencies (AssertElseError _ bb1 _ _) = dependencies bb1
-    dependencies (Call _ t1 t2) = dependencies t1  >> dependencies t2
+    dependencies (StackExpand _ t1 t2) = dependencies t1  >> dependencies t2
 
     dependencies _              = return ()
 instance ComputesDependencies FunDef where
@@ -231,15 +231,15 @@ instance WellFormedIRCheck IRInst where
  wfir (Assign (VN x) e) = do checkId x
                              wfir e
  wfir (MkFunClosures _ fdefs) = mapM_ (\((VN x), _) -> checkId x) fdefs
- 
+
 
 instance WellFormedIRCheck IRTerminator where
   wfir (If _ bb1 bb2) = do
     wfir bb1
     wfir bb2
   wfir (AssertElseError _ bb _ _) = wfir bb
-  wfir (Call (VN x) bb1 bb2 ) = do 
-    checkId x 
+  wfir (StackExpand (VN x) bb1 bb2 ) = do
+    checkId x
     wfir bb1
     wfir bb2
 
@@ -442,7 +442,8 @@ ppIR (MkFunClosures varmap fdefs) =
 
 
 
-ppTr (Call vn bb1 bb2) = (ppId vn <+> text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2)
+
+ppTr (StackExpand vn bb1 bb2) = (ppId vn <+> text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2)
 
 
 ppTr (AssertElseError va ir va2 _) 

compiler/src/IR2Raw.hs

@@ -699,7 +699,7 @@ tr2raw = \case
     return $ If r bb1' bb2'
 
   -- Revision 2023-08: Equivalent, only way of modifying bb2 changed.
-  IR.Call v irBB1 irBB2 -> do
+  IR.StackExpand v irBB1 irBB2 -> do
     bb1 <- tree2raw irBB1
     BB insts2 tr2 <- tree2raw irBB2
     -- Prepend before insts2 instructions to store in variable v the result
@@ -711,7 +711,7 @@ tr2raw = \case
                                   -- generally using Sequence (faster concatenation) for instructions
                                   -- might improve performance
     let bb2 = BB insts2' tr2
-    return $ Call bb1 bb2
+    return $ StackExpand bb1 bb2
 
   -- Note: This is translated into branching and Error for throwing RT exception
   -- Revision 2023-08: More fine-grained raising of blocking label, see below.

compiler/src/IROpt.hs

@@ -67,7 +67,7 @@ instance Substitutable IRTerminator where
                 AssertElseError (apply subst x) (apply subst bb) (apply subst y) pos 
             LibExport x -> LibExport (apply subst x)
             Error x pos -> Error (apply subst x) pos 
-            Call decVar bb1 bb2 -> Call decVar (apply subst bb1) (apply subst bb2)
+            StackExpand decVar bb1 bb2 -> StackExpand decVar (apply subst bb1) (apply subst bb2)
 
 instance Substitutable IRBBTree where 
     apply subst (BB insts tr) = 
@@ -462,7 +462,7 @@ trPeval (AssertElseError x bb y_err pos) = do
                 return $ BB [] (AssertElseError x bb' y_err pos)     
 
 
-trPeval (Call x bb1 bb2) = do 
+trPeval (StackExpand x bb1 bb2) = do 
     bb1' <- peval bb1 
     bb2' <- peval bb2
 
@@ -473,7 +473,7 @@ trPeval (Call x bb1 bb2) = do
             setChangeFlag           
             return $ BB (insts1 ++ insts2) tr2
         _ -> 
-            return $ BB [] (Call x bb1' bb2')
+            return $ BB [] (StackExpand x bb1' bb2')
 
 trPeval tr@(Ret x) = do 
     markUsed' x 

compiler/src/Raw.hs

@@ -158,7 +158,7 @@ data RawTerminator
   | Error RawVar PosInf
   -- | Execute the first BB and then execute the second BB where
   -- PC is reset to the level before entering the first BB.
-  | Call RawBBTree RawBBTree
+  | StackExpand RawBBTree RawBBTree
   deriving (Eq, Show)
 
 
@@ -341,7 +341,7 @@ ppIR (MkFunClosures varmap fdefs) =
 -- ppIR (LevelOperations _ insts) = 
 --  text "level operation" $$ nest 2 (vcat (map ppIR insts))
 
-ppTr (Call bb1 bb2) = (text "call" $$ nest 4 (ppBB bb1)) $$ (ppBB bb2)
+ppTr (StackExpand bb1 bb2) = (text "call" $$ nest 4 (ppBB bb1)) $$ (ppBB bb2)
 
 
 -- ppTr (AssertElseError va ir va2 _) 

compiler/src/Raw2Stack.hs

@@ -188,7 +188,7 @@ trTr (Raw.LibExport v) = do
      return $ Stack.LibExport v 
 trTr (Raw.Error r1 p) = do 
      return $ Stack.Error r1 p 
-trTr (Raw.Call bb1 bb2) = do 
+trTr (Raw.StackExpand bb1 bb2) = do 
    __callDepth <- localCallDepth <$> ask 
    bb1' <- local (\tenv -> tenv { localCallDepth = __callDepth + 1 } ) $ trBB bb1 
    n <- getBlockNumber
@@ -205,7 +205,7 @@ trTr (Raw.Call bb1 bb2) = do
                     | x <-  filter filterConsts (Set.elems varsToLoad) ]   
    bb2'@(Stack.BB inst_2 tr_2) <- trBB bb2
 
-   return $ Stack.Call bb1' (Stack.BB (loads ++ inst_2) tr_2)
+   return $ Stack.StackExpand bb1' (Stack.BB (loads ++ inst_2) tr_2)
 
 
 trBB :: Raw.RawBBTree -> Tr Stack.StackBBTree 

compiler/src/RawDefUse.hs

@@ -233,7 +233,7 @@ instance Trav RawTerminator where
          trav bb2
        LibExport v -> use v 
        Error r _ -> use r 
-       Call bb1 bb2 -> do
+       StackExpand bb1 bb2 -> do
          trav bb1
          modify (\s -> 
                      let (c, _) = locInfo s 

compiler/src/RawOpt.hs

@@ -78,7 +78,7 @@ instance Substitutable RawTerminator where
       If r bb1 bb2 -> 
         If (apply subst r) (apply subst bb1) (apply subst bb2)
       Error r p -> Error (apply subst r) p 
-      Call bb1 bb2 -> Call (apply subst bb1) (apply subst bb2) 
+      StackExpand bb1 bb2 -> StackExpand (apply subst bb1) (apply subst bb2) 
       _ -> tr
 
 instance Substitutable RawBBTree where
@@ -420,15 +420,15 @@ instance PEval RawTerminator where
                 }
         bb2' <- peval bb2         
         return $ If x bb1' bb2'
-      Call bb1 bb2 -> do
+      StackExpand bb1 bb2 -> do
         s <- get
         bb1' <- peval bb1
         put $ s { stateMon = Map.empty
                 , stateLVals = stateLVals s
                 , stateJoins = stateJoins s 
                 } -- reset the monitor state
         bb2' <- peval bb2
-        return $ Call bb1' bb2'
+        return $ StackExpand bb1' bb2'
       Ret -> do 
         return tr' 
       TailCall x -> do 
@@ -470,14 +470,15 @@ filterInstBwd ls =
   f (Nothing, Nothing) (reverse ls) []
 
 
--- | This optimization for 'Call' moves instructions from the continuation to before the 'Call'.
--- This can result in a 'Call' which just contains a 'Ret', which is then optimized away.
--- The optimization compensates for redundant assignments introduced by the translation.
-hoistCalls :: RawBBTree -> RawBBTree
-hoistCalls bb@(BB insts tr) = 
+-- | This optimization for 'StackExpand' moves instructions from the continuation to before the
+-- 'StackExpand'. This can result in a 'StackExpand' which just contains a 'Ret', which is then
+-- optimized away. The optimization compensates for redundant assignments introduced by the
+-- translation.
+hoistStackExpand :: RawBBTree -> RawBBTree
+hoistStackExpand bb@(BB insts tr) = 
   case tr of 
     -- Here we check which instructions from ii_1 can be moved to before the call
-    Call (BB ii_1 tr_1) bb2 ->
+    StackExpand (BB ii_1 tr_1) bb2 ->
       let isFrameSpecific i = 
             case i of 
               SetBranchFlag -> True
@@ -487,7 +488,7 @@ hoistCalls bb@(BB insts tr) =
           -- jx_1: non-frame-specific instructions, are moved to before the call
           -- jx_2: frame-specific instructions, stay under the call's instructions
           (jx_1, jx_2)  = Data.List.break isFrameSpecific ii_1  
-      in BB (insts ++ jx_1) (Call (BB jx_2 tr_1) bb2) 
+      in BB (insts ++ jx_1) (StackExpand (BB jx_2 tr_1) bb2) 
     -- If returning, the current frame will be removed, and thus all PC set instructions
     -- are redundant and can be removed.
     Ret -> 
@@ -537,7 +538,7 @@ instance PEval RawBBTree where
                 If x (BB (set_pc_bl ++ i_then) tr_then) 
                      (BB (set_pc_bl ++ i_else) tr_else)
 
-            _ -> hoistCalls $ BB (insts_no_ret ++ set_pc_bl) tr''
+            _ -> hoistStackExpand $ BB (insts_no_ret ++ set_pc_bl) tr''
     let insts_sorted = instOrder insts_ 
     return $ BB insts_sorted bb_
 

compiler/src/Stack.hs

@@ -47,7 +47,7 @@ data StackTerminator
   | If RawVar StackBBTree StackBBTree
   | LibExport VarAccess
   | Error RawVar PosInf
-  | Call  StackBBTree StackBBTree
+  | StackExpand  StackBBTree StackBBTree
   deriving (Eq, Show)
 
 
@@ -150,7 +150,7 @@ ppIR (MkFunClosures varmap fdefs) =
 ppIR (LabelGroup insts) = 
  text "group" $$ nest 2 (vcat (map ppIR insts))
 
-ppTr (Call bb1 bb2) = (text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2)
+ppTr (StackExpand bb1 bb2) = (text "= call" $$ nest 2 (ppBB bb1)) $$ (ppBB bb2)
 
 
 -- ppTr (AssertElseError va ir va2 _) 

compiler/src/Stack2JS.hs

@@ -452,7 +452,7 @@ ir2js InvalidateSparseBit = return $
 {-- TERMINATORS --}
 
 
-tr2js (Call bb bb2) = do
+tr2js (StackExpand bb bb2) = do
     _frameSize <- gets frameSize
     _sparseSlot <- gets sparseSlot
     _consts <- gets consts

compiler/test/ir2raw-test/testcases/TR.hs

@@ -30,8 +30,8 @@ tcs = map (second mkP)
        (BB [Assign (VN "b1") (Base "v1") ] (LibExport (mkV "b1")))
        (BB [Assign (VN "b2") (Base "v2") ] (LibExport (mkV "b2")))
   ),
-  ( "Call"
-  , Call (VN "x")
+  ( "StackExpand"
+  , StackExpand (VN "x")
        (BB [Assign (VN "b1") (Base "v1") ] (LibExport (mkV "b1")))
        (BB [Assign (VN "b2") (Base "v2") ] (LibExport (mkV "b2")))
   ),

lib/Hash.trp

@@ -68,15 +68,13 @@ let
 
     (*--- Module ---*)
     val Hash = {
-        hashString        = hashString,
-        hashMultiplyShift = hashMultiplyShift,
-        hashInt           = hashInt,
-        hashNumber        = hashNumber,
-        hashList          = hashList,
-        hash              = hash
+        hashString,
+        hashMultiplyShift,
+        hashInt,
+        hashNumber,
+        hashList,
+        hash
     }
 
-in [ ("Hash", Hash)
-   , ("hash", hash)
-   ]
+in [ ("Hash", Hash), ("hash", hash) ]
 end

lib/HashMap.trp

@@ -202,24 +202,20 @@ let (* NOTE: The map is implemented as a Hash Array Mapped Trie (HAMT), i.e. a p
 
     (*--- Module ---*)
     val HashMap = {
-        (* Construction *)
-        empty     = empty,
-        singleton = singleton,
-        insert    = insert,
-        remove    = remove,
-        (* Queries *)
-        null      = null,
-        size      = size,
-        findOpt   = findOpt,
-        find      = find,
-        mem       = mem,
-        (* Manipulation *)
-        fold      = fold,
-        (* List Conversion*)
-        keys      = keys,
-        values    = values,
-        toList    = toList,
-        fromList  = fromList
+        empty,
+        singleton,
+        insert,
+        remove,
+        null,
+        size,
+        findOpt,
+        find,
+        mem,
+        fold,
+        keys,
+        values,
+        toList,
+        fromList
     }
 
 in [ ("HashMap", HashMap) ]