[hoopl] refactor the op conversion process

hoopl/ConstProp.hs

@@ -18,7 +18,7 @@ import Compiler.Hoopl
 -- Type and definition of the lattice
 
 type M = CheckingFuelMonad (SimpleUniqueMonad)
-type ConstFact = Map.Map Int (WithTop Expr)
+type ConstFact = Map.Map Reg (WithTop Expr)
 constLattice :: DataflowLattice ConstFact
 constLattice = DataflowLattice
  { fact_name = "Constant propagation"

hoopl/DeadRegs.hs

@@ -15,11 +15,11 @@ import Compiler.Hoopl
 
 -- DeadRegsFact:
 -- The set of registers alive at that point
-type DeadRegsFact = S.Set Int
+type DeadRegsFact = S.Set Reg
 
 type M = CheckingFuelMonad (SimpleUniqueMonad)
 
-deadRegsInitFact :: S.Set Int
+deadRegsInitFact :: S.Set Reg
 deadRegsInitFact = S.empty
 
 deadRegsLattice :: DataflowLattice DeadRegsFact

hoopl/Insn.hs

@@ -1,18 +1,20 @@
 {-# LANGUAGE ViewPatterns,GADTs,StandaloneDeriving,NoMonomorphismRestriction #-}
-module Insn (Insn(..),Expr(..),mapE,insnToGraph,insnTarget,exprs) where
+module Insn (Reg,Insn(..),Expr(..),mapE,insnToGraph,insnTarget,exprs) where
 import Compiler.Hoopl
 -- a side effect free expression
 -- FIXME handle Box and Ann smartly
-data Expr = Double Double |  StrLit String | ScopedLex String | Reg Int
+
+type Reg = Int
+data Expr = Double Double |  StrLit String | ScopedLex String | Reg Reg
     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
-    BifMinus :: Int -> Expr -> Expr -> Insn O O
-    BifDivide :: Int -> Expr -> Expr -> Insn O O
-    RegSet  :: Int -> Expr -> Insn O O
+    Fetch :: Reg -> Expr -> Insn O O
+    Subcall :: Reg -> [Expr] -> Insn O O
+    BifPlus :: Reg -> Expr -> Expr -> Insn O O
+    BifMinus :: Reg -> Expr -> Expr -> Insn O O
+    BifDivide :: Reg -> Expr -> Expr -> Insn O O
+    RegSet  :: Reg -> Expr -> Insn O O
 
 deriving instance Show (Insn e x)
 
@@ -46,10 +48,10 @@ insnToGraph n@(RegSet _ _)    = mkMiddle n
 
 
 -- the register the instruction writes to
-insnTarget :: Insn e x -> Maybe Int
+insnTarget :: Insn e x -> Maybe Reg
 insnTarget insn = Just $ r insn
     where 
-          r :: Insn e x -> Int
+          r :: Insn e x -> Reg
           r (Fetch reg _) = reg
           r (Subcall reg _) = reg
           r (BifPlus reg _ _) = reg

hoopl/Nam.hs

@@ -17,16 +17,33 @@ import Util
 instance NonLocal (Insn) 
 
 
+type CM a = State Int a
 
 
-freshId = do
+freshID :: CM Reg
+freshID = do
     id <- get
     put (id+1)
     return $ id
 
 simple val = return $ (emptyGraph,val) 
 
-convert :: Op.Op -> State Int ((Graph Insn O O),Expr)
+-- TODO: pick better name?
+composit args func = do
+    converted <- mapM convert args
+    let (setup,vals) = unzip converted
+    (extraSetup,ret) <- func vals
+    return ((foldl (<*>) emptyGraph  setup) <*> extraSetup,ret)
+
+basicInsn :: [Op.Op] -> (Reg -> [Expr] -> Insn O O) ->  CM ((Graph Insn O O),Expr)
+
+basicInsn args transform = do
+    id <- freshID
+    composit args (\vals ->
+        return (mkMiddle $ transform id vals,Reg id))
+
+
+convert :: Op.Op -> CM ((Graph Insn O O),Expr)
 
 -- ops which map directly to Expr
 
@@ -41,39 +58,17 @@ convert (Op.Box _ op) = convert op
 convert (Op.Const op) = convert op
 
 
-convert (Op.Prog ops) = do
-    converted <- mapM convert ops
-    let (setup,vals) = unzip converted
-    return $ (foldl1 (<*>) setup,last vals)
+convert (Op.Prog ops) = composit ops (\vals -> return (emptyGraph,last vals))
 
-convert (Op.Subcall args) = do
-    converted <- mapM convert args
-    let (setup,vals) = unzip converted
-    id <- freshId
-    return $ (((foldl1 (<*>) setup) <*> (mkMiddle $ Subcall id vals)),Reg id)
-
-convert (Op.Fetch arg) = do
-    id <- freshId
-    (setup,val) <- convert arg
-    return $ (setup <*> (mkMiddle $ Fetch id val),Reg id)
-
-convert (Op.BifPlus a b) = do
-    id <- freshId
-    (setup1,val1) <- convert a
-    (setup2,val2) <- convert b
-    return $ (setup1 <*> setup2 <*> (mkMiddle $ BifPlus id val1 val2),Reg id)
-
-convert (Op.BifDivide a b) = do
-    id <- freshId
-    (setup1,val1) <- convert a
-    (setup2,val2) <- convert b
-    return $ (setup1 <*> setup2 <*> (mkMiddle $ BifDivide id val1 val2),Reg id)
-
-convert (Op.BifMinus a b) = do
-    id <- freshId
-    (setup1,val1) <- convert a
-    (setup2,val2) <- convert b
-    return $ (setup1 <*> setup2 <*> (mkMiddle $ BifMinus id val1 val2),Reg id)
+convert (Op.Subcall args) = basicInsn args Subcall
+
+convert (Op.Fetch arg) = basicInsn [arg] (\reg [arg] -> Fetch reg arg)
+
+convert (Op.BifPlus a b) = basicInsn [a,b] (\reg [a,b] -> BifPlus reg a b)
+
+convert (Op.BifDivide a b) = basicInsn [a,b] (\reg [a,b] -> BifDivide reg a b)
+
+convert (Op.BifMinus a b) = basicInsn [a,b] (\reg [a,b] -> BifMinus reg a b)
 
 convert (Op.Sink arg) = convert arg