ReductionMachine.hs

module ReductionMachine where

-- Abstract lazy functional pure assembly language 

-- Programs (libraries containing a "main") in this language could
-- in principle be assembled on to run directly on the computer.

-- a full program is a pile of named Funcs, one of them "main"
type Lib = [(CodeName, Func)]
type Func = ([VarName], Body)

-- code for body of a function
data Body =
  Let VarName Laziness Op (Maybe Body) | -- let x = op in ...
  Case VarName [Alt Body] -- case x of A -> ...; B -> ...; ...
    deriving Show

data Laziness = Eager | Lazy deriving Show

data Alt a = Alt String [VarName] a
  deriving Show

-- verbatim assembly operation
data Op =
  Force VarName |
  Apply Int VarName [VarName] |
  Data Int String [VarName] |
  LitI Integer |
  LitD Double |
  Error
    deriving Show

type CodeName = String
type VarName = String

-- Below is an emulator which will run the language above without
-- assembling it. The idea is, your program returns data which 
-- indicates what I/O to do and a continuation for what to with the
-- result. (free monad pattern).

-- It knows how to use 3 primitive operations on machine numbers:
-- integer addition, integer less-than, and sine. Of course these
-- would be assembled to use real machine primitives. The names
-- "add" "lt" and "sin" should be left undefined in the Lib.

-- runtime object for "values"
data Obj =
  D String [Obj] |       -- data, [D K _ _ _ _]
  C CodeName [Obj] Int | -- closure, [F C 2 _ _]
  T DelayedOp |          -- thunk [T S _]
  N Integer Double       -- machine word [N W]
    deriving Show

-- operation ready to be executed
data DelayedOp =
  TF Obj |              -- force this
  TA Int Obj [Obj] |    -- apply n arguments
  TD Int String [Obj] | -- construct (lazy) data
  TV Obj |              -- just return this value
  TE                    -- halt and catch fire
    deriving Show

type Env = [(VarName, Obj)]

-- evaluate the body of the function "main" in lib (to WHNF)
exec :: Lib -> Obj
exec lib = force lib [] (go lib [] body) where
  ([],body) = lookupFunc lib "main"

-- consume body statements. Will crunch, branch, return an answer,
-- might loop or crash instead.
go :: Lib -> Env -> Body -> Obj
go lib env body = case body of
  Let v susp instr next ->
    let obj = runOp lib env susp instr in
    case next of
      Nothing -> obj
      Just body' -> go lib ((v,obj):env) body'
  Case v alts ->
    let obj = force lib env (lookupVar env v) in
    case obj of
      D c xs ->
        let (env', body') = branch env c xs alts in
        go lib env' body'
      T _ -> error "unexpected thunk (case)"
      _ -> error "case analysis of non-data"

-- execute or suspend an instruction
runOp :: Lib -> Env -> Laziness -> Op -> Obj
runOp lib env susp instr = result where
  result = case susp of
    Eager -> crunch lib env op
    Lazy  -> T op
  op = case instr of --prepare instruction to be executed
    Force u -> TF (lookupVar env u)
    Apply n fv vs ->
      let f = force lib env (lookupVar env fv) in
      let ys = map (lookupVar env) vs in
      TA n f ys
    Data n c vs -> TD n c (map (lookupVar env) vs)
    LitI i -> TV (N i 0)
    LitD x -> TV (N 0 x)
    Error -> TE

-- attempt to force an object to non-thunk form, may fail
force :: Lib -> Env -> Obj -> Obj
force lib env obj = case obj of
  T hmm -> crunch lib env hmm
  _ -> obj

-- execute a prepared instruction
crunch :: Lib -> Env -> DelayedOp -> Obj
crunch lib env op = case op of
  TV v -> v
  TD n c xs -> D c xs
  TA n f xs -> apply lib env n f xs
  TF x -> force lib env x
  TE -> error "ERROR"

-- figure out where to go next based on alternatives
-- unpack the matching object's contents for use in the continuation
branch :: Env -> String -> [Obj] -> [Alt Body] -> (Env, Body)
branch env c xs alts = case alts of
  ((Alt "_" [] body):more) -> (env, body)
  ((Alt c' sig body):more)
    | c == c'   -> (catEnv env sig xs, body)
    | otherwise -> branch env c xs more
  [] -> error "ran out of alternatives"

-- apply a function to arguments
apply :: Lib -> Env -> Int -> Obj -> [Obj] -> Obj
apply lib env n f ys = case f of
  C "add" _ 2 -> let [N a _, N b _] = ys in N (a + b) 0 
  C "lt" _ 2  -> let [N a _, N b _] = ys in
                 if a < b then D "T" [] else D "F" []
  C "sin" _ 1 -> let [N _ x] = ys in N 0 (sin x)
  C name xs needed
    | n == needed -> let (sig,body) = lookupFunc lib name
                     in go lib (catEnv env sig ys) body
    | n < needed -> C name (xs ++ ys) (needed - n)
    | n > needed -> let (sig,body) = lookupFunc lib name in 
                    let (args, rest) = splitAt n ys in
                    let g = go lib (catEnv env sig args) body in
                    apply lib env (n - needed) g rest
  T _ -> error "unexpected thunk (apply)"
  _ -> error "application of non-function"


-- utilities

catEnv :: Env -> [VarName] -> [Obj] -> Env
catEnv env vs objs = env ++ (zip vs objs)

lookupFunc :: Lib -> CodeName -> Func
lookupFunc lib name = case lookup name lib of
  Just x -> x
  Nothing -> error ("function " ++ name ++ " not found")

lookupVar :: Env -> VarName -> Obj
lookupVar env name = case lookup name env of
  Just x -> x
  Nothing -> error ("var " ++ name ++ " not found")