-- Detecting sharing in embedded DSLs
-- Illustrating the three main approaches reviewed in
-- Alfonso Acosta's ForSyDe thesis
module Ptrs where
import Control.Monad.State
import Data.IORef -- for observable sharing
import System.IO.Unsafe
-- All three approaches are based on a sort of `pointer' comparison.
-- Or, on labeling expressions with unique pieces of data (e.g., integers)
-- that admit efficient comparison
-- Labeled expressions
type Lab = Int
data ExpL
= AddL Lab ExpL ExpL
| VariableL Lab String
| ConstantL Lab Int
deriving Show
-- ExpL expressions can be compared in constant time, by comparing the
-- labels, presumed unique. The full traversal is no longer needed
instance Eq ExpL where
e1 == e2 = label e1 == label e2
where
label (AddL p _ _) = p
label (ConstantL p _) = p
label (VariableL p _) = p
-- The first approach: manual labeling
-- Sample expressions
-- Manual labelling is clearly cumbersome and error-prone
-- (although Template Haskell greatly helps)
expL_a = AddL 3 (ConstantL 1 10) (VariableL 2 "i1")
expL_b = AddL 4 expL_a (VariableL 5 "i2")
-- The multiplication example reads as follows.
-- The function mulL takes an extra argument, the initial label counter,
-- and returns the final counter as the extra result.
mulL :: Int -> ExpL -> Lab -> (Lab,ExpL)
mulL 0 _ p = (p+1, ConstantL p 0)
mulL 1 x p = (p,x)
mulL n x p | n `mod` 2 == 0 = mulL (n `div` 2) (AddL p x x) (p+1)
mulL n x p = let (p',r) = mulL (n-1) x p in (p'+1, AddL p' x r)
-- Last-but-one line shows a crucial point: two children of AddL
-- will have the same label
expL_mul4 = mulL 4 (VariableL 0 "i1") 1
{-
(3,AddL 2 (AddL 1 (VariableL 0 "i1") (VariableL 0 "i1"))
(AddL 1 (VariableL 0 "i1") (VariableL 0 "i1")))
-}
expL_mul8 = mulL 8 (VariableL 0 "i1") 1
{-
(4,
AddL 3
(AddL 2
(AddL 1 (VariableL 0 "i1") (VariableL 0 "i1"))
(AddL 1 (VariableL 0 "i1") (VariableL 0 "i1")))
(AddL 2
(AddL 1 (VariableL 0 "i1") (VariableL 0 "i1"))
(AddL 1 (VariableL 0 "i1") (VariableL 0 "i1"))))
-}
-- Approach 2: use the state monad to automate label assignment.
-- The state monad was already apparent in the implementation of mulL
type ExpM = State Lab ExpL
new_labelM :: State Lab Lab
new_labelM = do
p <- get
put (p+1)
return p
-- `smart constructors' to construct expressions,
-- obtaining the fresh label
varM :: String -> ExpM
varM v = new_labelM >>= \p -> return $ VariableL p v
constM :: Int -> ExpM
constM x = new_labelM >>= \p -> return $ ConstantL p x
addM :: ExpL -> ExpL -> ExpM
addM x y = new_labelM >>= \p -> return $ AddL p x y
{-
-- Exercise: what is the problem with the following definition?
addM :: ExpM -> ExpM -> ExpM
addM x y = do
xv <- x
yv <- y
l <- new_labelM
return $ AddL l xv yv
expM_a = addM (constM 10) (varM "i1")
-}
run_expM :: ExpM -> ExpL
run_expM m = evalState m 0
-- The running examples
{- O'Donnell wrote (cited from Alfonso Acosta's thesis):
``A more severe problem is that the circuit specification is no longer
a system of simultaneous equations, which can be manipulated formally
just by 'substituting equals for equals'. Instead, the specification
is now a sequence of computations that --when executed-- will yield
the desired circuit. It feels like writing an imperative program to
draw a circuit, instead of defining the circuit directly."[33]''
-}
expM_a = do
xv <- constM 10
yv <- varM "i1"
addM xv yv
expM_b = do
xv <- expM_a
yv <- varM "i2"
addM xv yv
{-
*Ptrs> run_expM expM_b
AddL 4 (AddL 2 (ConstantL 0 10) (VariableL 1 "i1")) (VariableL 3 "i2")
-}
-- The monadic notation simplifies mulL, hiding the label counter
-- manipulation
-- (=<<) as a call-by-value application
mulM :: Int -> ExpL -> ExpM
mulM 0 _ = constM 0
mulM 1 x = return x
mulM n x | n `mod` 2 == 0 = mulM (n `div` 2) =<< addM x x
mulM n x = addM x =<< mulM (n-1) x
-- Last-but-one line shows a crucial point: two children of AddL
-- will have the same label
expM_mul4 = mulM 4 =<< (varM "i1")
{-
*Ptrs> run_expM expM_mul4
AddL 2
(AddL 1 (VariableL 0 "i1") (VariableL 0 "i1"))
(AddL 1 (VariableL 0 "i1") (VariableL 0 "i1"))
-}
-- Approach 3: observable sharing
-- The other approach: see Naylor (LavaUnsafe)
-- Why do we need NOINLINE?
{-# NOINLINE counter #-}
counter = unsafePerformIO (newIORef 0)
-- gensym, essentially
new_label :: () -> Int
new_label () = unsafePerformIO $ do
p <- readIORef counter
writeIORef counter (p+1)
return p
varU :: String -> ExpL
varU v = VariableL (new_label ()) v
constU :: Int -> ExpL
constU x = ConstantL (new_label ()) x
-- Apparently a pure type
addU :: ExpL -> ExpL -> ExpL
addU x y = AddL (new_label ()) x y
-- Why can't we eta-reduce the definitions?
-- constU = ConstantL (new_label ())
-- varU = VariableL (new_label ())
-- addU = AddL (new_label ())
-- This is the price of lying to the compiler
-- Sample expression
expU_a = addU (constU 10) (varU "i1")
-- AddL 0 (ConstantL 1 10) (VariableL 2 "i1")
expU_b = addU expU_a (varU "i2")
-- AddL 3 (AddL 0 (ConstantL 1 10) (VariableL 2 "i1")) (VariableL 4 "i2")
-- The attraction: pure type, pure applications
mulU :: Int -> ExpL -> ExpL
mulU 0 _ = constU 0
mulU 1 x = x
mulU n x | n `mod` 2 == 0 = mulU (n `div` 2) (addU x x)
mulU n x = addU x (mulU (n-1) x)
-- Equal expressions got equal labels
expU_mul4 = mulU 4 (varU "i1")
{-
AddL 0 (AddL 1 (VariableL 2 "i1") (VariableL 2 "i1"))
(AddL 1 (VariableL 2 "i1") (VariableL 2 "i1"))
-}
expU_mul8 = mulU 8 (varU "i1")
{-
AddL 3
(AddL 4 (AddL 5 (VariableL 6 "i1") (VariableL 6 "i1"))
(AddL 5 (VariableL 6 "i1") (VariableL 6 "i1")))
(AddL 4 (AddL 5 (VariableL 6 "i1") (VariableL 6 "i1"))
(AddL 5 (VariableL 6 "i1") (VariableL 6 "i1")))
-}
main = do
print expL_mul8
print $ run_expM expM_mul4
print $ expU_b
print expU_mul8