Merge pull request #29 from felixwiemuth/ir2raw-revision

New IR2Raw phase with improvements and fixes

.vscode/tasks.json

@@ -3,6 +3,24 @@
     // for the documentation about the tasks.json format
 	  "version": "2.0.0",
 	  "tasks": [
+		{
+			"label": "Compile",
+			"type": "shell",
+			"command": "${workspaceFolder}/bin/troupec -v ${file}",
+			"group": {
+				"kind": "build",
+				"isDefault": true
+			},
+			"presentation": {
+				"echo": true,
+				"reveal": "always",
+				"focus": false,
+				"panel": "shared",
+				"showReuseMessage": true,
+				"clear": false
+			},
+			"problemMatcher": []
+		},
 		{
 			"label": "Run local",
 			"type": "shell",

README.md

@@ -9,19 +9,21 @@ If you want to try out Troupe without manual installation (e.g., for a class exe
 
 ## Installation
 
+Once all dependencies have been installed, the whole project can be built and Troupe installed to the `bin` directory with `make all`. The following shows step-by-step which dependencies are needed for which parts and how to install them.
 
 ### Step 1. Install JS runtime
 1. Install NodeJS (e.g. `sudo apt-get install nodejs`)
 2. Get [yarn](https://yarnpkg.com/lang/en/) package manager (e.g. `npm install --global yarn`)
 3. Install js dependencies via `yarn install`
-4. Apply local js patches to the dependencies via `yarn patch-package`
+4. Apply local js patches to the dependencies via `yarn patch-package` (might already be executed by `yarn install`)
 5. Set the `TROUPE` environment variable to point to the folder that contains this README. In bash this is done by adding the following lines to a file such as `~/.bashrc` or `~/.bash_profile`:
    ```
    TROUPE=<path to the installation directory>
    export TROUPE=<path to the installation directory>
    ```
    Read <a href="https://www.digitalocean.com/community/tutorials/how-to-read-and-set-environmental-and-shell-variables-on-a-linux-vps"> here</a> for more info on environment variables.
 6. Install [TypeScript](https://www.typescriptlang.org/): `npm install -g typescript`
+   - To install to the home directory without root, first run `npm config set prefix ~/.npm` and add `~/.npm/bin` to your PATH
 7. Compile Troupe runtime by typing `make rt`
 
 ### Step 2. Install Troupe compiler
@@ -40,7 +42,10 @@ Type `make stack` (in the repository's root) to compile Troupe's bin scripts
 
 ### Step 4. Install Troupe standard library
 
-Type `make libs` to compile Troupe's built-in libraries, and `make service` to compile the service module placeholder.
+Type
+
+- `make libs` to compile Troupe's built-in libraries, and
+- `make service` to compile the service module placeholder.
 
 
 ### Step 5. Running the test suite
@@ -92,6 +97,13 @@ This will allow to develop on a remote machine, using VSCode on a local machine
 Now, when having opened the `compiler` folder, the Haskell Language Server should highlight errors and hints, support "Go to definition" and more.
 
 
+#### Syntax support for Troupe files
+
+As Troupe syntax is similar to SML, installing the [SML Environment](https://marketplace.visualstudio.com/items?itemName=vrjuliao.sml-environment) extension is useful. It adds syntax highlighting, some identation support and support for commenting with editor commands.
+
+Use `Ctrl-k m` ("Change language mode") to set the current file's language mode to SML. The suggestions will also allow to generally associate `.trp` files with SML mode.
+
+
 #### Building and running
 
 - **Building the compiler:** When having opened the `compiler` folder, there is a task "Build all", which is set as the default build task, so running "Run build task" (Ctrl-F9) should execute it.
@@ -108,6 +120,20 @@ Now, when having opened the `compiler` folder, the Haskell Language Server shoul
 The current user guide is accessible [here](https://troupe.cs.au.dk/userguide.pdf).
 
 ## Building and running
+### Building
+
+The following commands build specific parts of the project and install the results to the `bin`, `rt/built` and `lib` directories.
+
+- `make all`: build everything (use this whenever significant changes have been made to the project, to be sure that everything is up-to-date)
+- `make` / `make stack`: build the compiler
+- `make rt`: build the runtime (into the `rt/built` directory)
+- `make libs`: compile Troupe's built-in libraries (into the `lib` directory)
+- `make service` compile the service module placeholder
+
+### Tests
+
+- `make test` to run all tests
+- `bin/golden` to run the test suite with options
 
 ### Running examples that do not require network
 
@@ -117,7 +143,8 @@ infrastructure or key generation (which otherwise takes a few seconds).
 
 ### Building and naming the snapshot
 
-Script `build.sh` runs `make` and copies the executables to `../bin/<current git HEAD hash>`.
+Script `dev-utils/build.sh` runs `make` and copies the executables to `../bin/<current git HEAD hash>`.
+This is useful when wanting to compile some snapshots to compare how different versions behave.
 
 ## Networking
 

compiler/app/Main.hs

@@ -8,6 +8,7 @@ import qualified Core as Core
 import RetDFCPS
 import qualified CaseElimination as C
 import System.Environment
+import Util.FileUtil
 import qualified ClosureConv as CC
 import qualified IR as CCIR 
 -- import qualified IROpt
@@ -36,7 +37,6 @@ import System.Console.GetOpt
 import Data.List as List
 import Data.Maybe (fromJust)
 import System.FilePath
-import System.Directory
 
 -- import System.Console.Haskeline
 -- import System.Process
@@ -168,19 +168,6 @@ process flags fname input = do
 
 
 
--- A thin wrapper around system writeFile that creates a missing
--- directory; this is useful for creating out directories for
--- libraries and when the working project folder is just fetched from
--- the repo; 2018-07-15: AA
-
-writeFileD filename x = do
-  let dirpath = takeDirectory filename
-  createDirectoryIfMissing False dirpath -- do not create parent dirs
-                                         -- because this should never
-                                         -- be required in our use
-                                         -- cases
-  writeFile filename x
-
 
 writeExports jsF exports =
   let exF' = if takeExtension jsF == ".js" then dropExtension jsF else jsF

compiler/package.yaml

@@ -91,3 +91,14 @@ tests:
     - -with-rtsopts=-N
     dependencies:
     - Troupe-compiler
+  ir2raw-test:
+    main: IR2RawTest.hs
+    source-dirs:
+    - test/ir2raw-test
+    - test/ir2raw-test/testcases
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - Troupe-compiler

compiler/src/AtomFolding.hs

@@ -41,8 +41,10 @@ visitTerm atms (Tuple terms) =
 visitTerm atms (Record fields) =  Record (visitFields atms fields)    
 visitTerm atms (WithRecord e fields) = 
     WithRecord (visitTerm atms e) (visitFields atms fields)
-visitTerm atms (Proj t f) =
-    Proj (visitTerm atms t) f
+visitTerm atms (ProjField t f) =
+    ProjField (visitTerm atms t) f
+visitTerm atms (ProjIdx t idx) =
+    ProjIdx (visitTerm atms t) idx
 visitTerm atms (List terms) =
   List (map (visitTerm atms) terms)
 visitTerm atms (ListCons t1 t2) =

compiler/src/Basics.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Basics
 where
@@ -11,10 +12,11 @@ type VarName = String
 type AtomName = String
 type FieldName = String
 
-data BinOp = Plus | Minus | Mult | Div | Mod |  Eq | Neq | Le | Lt | Ge | Gt | And | Or | Index | RaisedTo | FlowsTo | Concat| IntDiv | BinAnd | BinOr | BinXor | BinShiftLeft | BinShiftRight | BinZeroShiftRight | HasField | LatticeJoin | LatticeMeet
+-- | Eq and Neq: deep equality check on the two parameters, including the types (any type inequality results in false being returned).
+data BinOp = Plus | Minus | Mult | Div | Mod |  Eq | Neq | Le | Lt | Ge | Gt | And | Or | RaisedTo | FlowsTo | Concat| IntDiv | BinAnd | BinOr | BinXor | BinShiftLeft | BinShiftRight | BinZeroShiftRight | HasField | LatticeJoin | LatticeMeet
   deriving (Eq,Generic, Ord)
 instance Serialize BinOp
-data UnaryOp = IsList | IsTuple | IsRecord | Head | Tail | Fst | Snd | Length | LevelOf | UnMinus
+data UnaryOp = IsList | IsTuple | IsRecord | Head | Tail | Fst | Snd | ListLength | TupleLength | LevelOf | UnMinus
   deriving (Eq, Generic, Ord)
 instance Serialize UnaryOp
 
@@ -33,7 +35,6 @@ instance Show BinOp where
   show Gt    = ">"  
   show And   = "&&"
   show Or    = "||"
-  show Index = "!!"
   show RaisedTo = "raisedTo"
   show FlowsTo  = "flowsTo"
   show Concat   = "^"
@@ -47,18 +48,17 @@ instance Show BinOp where
   show LatticeJoin = "join"
   show LatticeMeet = "meet"
 
-
-
 instance Show UnaryOp where
   show IsList = "is-list"
   show IsTuple = "is-tuple"
   show Head = "list-head"
   show Tail = "list-tail"
   show Fst = "fst"
   show Snd = "snd"
-  show Length = "length"
+  show ListLength = "list-length"
+  show TupleLength = "tuple-length"
   show LevelOf = "levelOf"
-  show UnMinus = "-"
+  show UnMinus = "un-minus"
   show IsRecord = "is-record"
 
 
@@ -94,7 +94,6 @@ opPrec Ge    = 50
 opPrec Gt    = 50
 opPrec And   = 50
 opPrec Or    = 50
-opPrec Index = 50
 opPrec FlowsTo    = 50
 opPrec RaisedTo   = 50
 opPrec HasField   = 50

compiler/src/CPSOpt.hs

@@ -71,7 +71,8 @@ instance Substitutable SimpleTerm where
       Tuple vs -> Tuple (map fwd vs)
       Record fields -> Record $ fwdFields fields
       WithRecord x fields -> WithRecord (fwd x) $ fwdFields fields
-      Proj x f -> Proj (fwd x) f
+      ProjField x f -> ProjField (fwd x) f
+      ProjIdx x idx -> ProjIdx (fwd x) idx
       List vs -> List (map fwd vs)
       ListCons v v' -> ListCons (fwd v) (fwd v')
       ValSimpleTerm sv -> ValSimpleTerm (apply subst sv)
@@ -138,8 +139,9 @@ instance CensusCollectible SimpleTerm where
       Tuple vs -> updateCensus vs 
       Record fs -> let (_,vs) = unzip fs in updateCensus vs 
       WithRecord v fs -> updateCensus v >> (let (_,vs) = unzip fs in updateCensus vs )
-      Proj v _ -> updateCensus v 
-      List vs -> updateCensus vs 
+      ProjField v _ -> updateCensus v
+      ProjIdx v _ -> updateCensus v
+      List vs -> updateCensus vs
       ListCons v vs -> updateCensus v >> updateCensus vs
       Base _ -> return () 
       Lib _ _ -> return ()
@@ -276,12 +278,6 @@ simplifySimpleTerm t =
     u <- look oper1 
     v <- look oper2
     case op of 
-      Basics.Index -> do 
-        case (u, v) of 
-          (St (Tuple xs), St (ValSimpleTerm  (Lit (C.LInt i _)))) ->
-            _subst $  xs !! (fromIntegral  i)             
-          _ -> _nochange       
-
       Basics.HasField -> case v of 
            St (ValSimpleTerm  (Lit (C.LString s))) -> do 
              fs <- fields oper1 
@@ -319,6 +315,7 @@ simplifySimpleTerm t =
               _ -> _nochange 
   Un op operand -> do
     v <- look operand 
+    -- TODO should write out all cases
     case (op,v) of 
         (Basics.IsTuple, St (Tuple _))          -> _ret __trueLit 
         (Basics.IsTuple, St (Record _))         -> _ret __falseLit
@@ -343,20 +340,30 @@ simplifySimpleTerm t =
         (Basics.IsList, St (Tuple _))         -> _ret __falseLit
         (Basics.IsList, St (ValSimpleTerm _)) -> _ret __falseLit
 
-        (Basics.Length, St (Tuple xs)) -> 
+        (Basics.TupleLength, St (Tuple xs)) -> 
+            _ret $ lit (C.LInt (fromIntegral (length xs)) NoPos)
+        -- 2023-08 Revision: Added this case
+        (Basics.ListLength, St (List xs)) -> 
             _ret $ lit (C.LInt (fromIntegral (length xs)) NoPos)
 
 
 
         _ -> _nochange
-  Proj x s ->  do 
+  ProjField x s ->  do 
     fs <- fields x
     case lookup s fs of 
       Just y -> _subst y 
       Nothing -> _nochange
-
-  ValSimpleTerm (KAbs klam) -> do 
-        klam' <- withResetRetState $ simpl klam 
+  ProjIdx x idx -> do
+    t <- look x
+    case t of
+      St (Tuple vs) | fromIntegral (length vs) > idx ->
+        _subst (vs !! fromIntegral idx)
+      _ -> _nochange
+
+
+  ValSimpleTerm (KAbs klam) -> do
+        klam' <- withResetRetState $ simpl klam
         _ret $ ValSimpleTerm $ KAbs klam'
 {--
   List _ -> _nochange 
@@ -396,7 +403,8 @@ failFree st = case st of
   Tuple _ -> True 
   Record _ -> True 
   WithRecord _ _ -> True 
-  Proj _ _ -> False 
+  ProjField _ _ -> False 
+  ProjIdx _ _ -> False 
   List _ -> True 
   ListCons _ _ -> False 
   Base _ -> True