[hoopl] added a constant propagation pass which does nothing but

typechecks

hoopl/ConstProp.hs

@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
+{-# LANGUAGE ScopedTypeVariables, GADTs, NoMonomorphismRestriction #-}
+module ConstProp (ConstFact, constLattice, initFact, varHasLit, constProp, constPropPass) where
+
+--import Control.Monad
+import Insn
+import qualified Data.Map as Map
+
+import Compiler.Hoopl
+--import IR
+--import OptSupport
+
+-- ConstFact:
+--   Not present in map => bottom
+--   PElem v => variable has value v
+--   Top     => variable's value is not constant
+-- Type and definition of the lattice
+
+type ConstFact = Map.Map Int (WithTop Expr)
+constLattice :: DataflowLattice ConstFact
+constLattice = DataflowLattice
+ { fact_name = "Constant propagation"
+ , fact_bot  = Map.empty
+ , fact_join = joinMaps (extendJoinDomain constFactAdd) }
+ where
+   constFactAdd _ (OldFact old) (NewFact new) 
+       = if new == old then (NoChange, PElem new)
+         else               (SomeChange, Top)
+
+-- Initially, we assume that all variable values are unknown.
+
+-- Only interesting semantic choice: values of variables are live across
+-- a call site.
+-- Note that we don't need a case for x := y, where y holds a constant.
+-- We can write the simplest solution and rely on the interleaved optimization.
+-- @ start cprop.tex
+--------------------------------------------------
+-- Analysis: variable equals a literal constant
+varHasLit :: FwdTransfer Insn ConstFact
+varHasLit = mkFTransfer ft
+ where
+  ft :: Insn e x -> ConstFact -> Fact x ConstFact
+
+  ft (BifPlus reg _ _)   f = Map.insert reg Top f
+  ft (Subcall reg _) f = Map.insert reg Top f
+  ft (Fetch reg _) f = Map.insert reg Top f
+  ft (RegSet reg constant@(Double _)) f = Map.insert reg (PElem constant) f
+  ft (RegSet reg _) f = Map.insert reg Top f
+
+constPropPass = FwdPass
+  { fp_lattice  = constLattice
+  , fp_transfer = varHasLit
+  , fp_rewrite  = constProp }
+
+initFact :: ConstFact
+initFact = Map.fromList []
+-- @ start cprop.tex
+--------------------------------------------------
+-- Rewriting: replace constant variables
+constProp :: FuelMonad m => FwdRewrite m Insn ConstFact
+constProp = mkFRewrite cp
+ where
+    cp node f = return Nothing

hoopl/Insn.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE ViewPatterns,GADTs,StandaloneDeriving,NoMonomorphismRestriction #-}
+module Insn (Insn(..),Expr(..)) where
+import Compiler.Hoopl
+-- a side effect free expression
+-- FIXME handle Box and Ann smartly
+data Expr = Double Double |  StrLit String | ScopedLex Expr | Reg Int
+    deriving (Show,Eq)
+
+data Insn e x where
+    Fetch :: Int -> Expr -> Insn O O
+    Subcall :: Int -> [Expr] -> Insn O O
+    BifPlus :: Int -> Expr -> Expr -> Insn O O
+    RegSet  :: Int -> Expr -> Insn O O

hoopl/Nam.hs

@@ -10,15 +10,8 @@ import qualified Op
 import qualified Data.Text as T
 import qualified Data.Vector as V
 import Control.Monad.State.Strict
+import Insn
 
--- a side effect free expression
--- FIXME handle Box and Ann smartly
-data Expr = Double Double |  StrLit String | ScopedLex Expr | Reg Int
-    deriving Show
-data Insn e x where
-    Fetch :: Int -> Expr -> Insn O O
-    Subcall :: Int -> [Expr] -> Insn O O
-    BifPlus :: Int -> Expr -> Expr -> Insn O O
 
 instance NonLocal (Insn) 
 

hoopl/nam.hs

@@ -1,4 +1,6 @@
 import Nam
+import ConstProp
+import Insn
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Aeson.Types as T
 import Data.Aeson.Parser;
@@ -8,6 +10,20 @@ import Compiler.Hoopl
 import Control.Monad.State.Strict
 import System.Environment
 mainLineNam = nam . head . xref
+
+type M = CheckingFuelMonad (SimpleUniqueMonad)
+
+unmonad :: M a -> a
+unmonad p = (runSimpleUniqueMonad $ runWithFuel 99999 p)
+
+analyze :: (Graph Insn O O) -> M (Graph Insn O O)
+analyze graph = do
+    (graph,_,_) <- analyzeAndRewriteFwdOx constPropPass graph initFact
+    return graph
+
+putGraph :: Graph Insn e x -> IO ()
+putGraph = putStrLn . showGraph ((++ "\n") . show)
+
 main = do
     [filename] <- getArgs
     namSource <- (B.readFile filename)
@@ -16,5 +32,9 @@ main = do
     putStrLn $ show parsed
 --    putStrLn $ show $ mainLineNam parsed
     let converted = fst $ evalState (convert $ mainLineNam parsed) 0
-    putStrLn "\ngraph:"
-    putStrLn $ showGraph ((++ "\n") . show) converted
+    let graph = (unmonad (analyze converted))
+    putStrLn "\norginal:"
+    putGraph converted
+    putStrLn "\nanalyzed:"
+    putGraph graph
+

hoopl/niecza-hoopl.cabal

@@ -51,7 +51,7 @@ Executable niecza-hoopl
     Main-is: nam.hs         
 
   -- Packages needed in order to build this package.
-   Build-depends: aeson >= 0.3.2.1,bytestring >= 0.9.1.5,vector >= 0.7.0.1,base >= 4,attoparsec >= 0.8.5.1 ,text, hoopl, mtl
+   Build-depends: aeson >= 0.3.2.1,bytestring >= 0.9.1.5,vector >= 0.7.0.1,base >= 4,attoparsec >= 0.8.5.1 ,text, hoopl, mtl, containers
 
 
   -- Modules not exported by this package.