{-# LANGUAGE
    FlexibleInstances #-}

-- Interpretation of Symantics that compiles to a sequence of
-- assembler operations (akin to SSA or CPS) with stripped types.

module SymAsm(Asm(..),asm) where

import Sym
import StateCont

-- The SC monad implements standard bind & return, transforming code
-- into Asm with state passing along side result values.

-- This operation is specialized to add memoization.  It assumes the
-- state is a dictionary of Strings.  We use Strings because we don't
-- need more structure to generate concrete syntax (passed to C
-- compiler or assembler).

type Tname = String
type Lname = String
type Opc   = String
type Var   = String
data Op    = Op Opc [Var]
           deriving Eq
                    
instance Show Op where
  show (Op opc vs)   = opc ++ (concat $ map (" " ++) vs)

data Binding = Assign Tname Var Op
             | Label Lname
instance Show Binding where
  show (Label label) =
    label ++ ":"
  show (Assign typ var op) = 
    concat $ [typ," ",var," <- ",show op]

data Env = Env { dict :: [Binding] }
instance Show Env where
  show (Env d) = concat $ map ((++ "\n") . show) (reverse d)

data Res = Res Env Var
instance Show Res where
  show (Res env var) = show env ++ var

-- Each `op' taps into the state-continuation monad's threading
-- structure.  The operation is associated to a name (variable) in the
-- dictionary.  This name is then passed to the continuation, passing
-- the updated dictionary as state.
op typ opc vs = SC c where
  c (Env d) k = k (Env d') v where
    v = newVar d
    o = Op opc vs
    d' = (Assign typ v o):d
    newVar d = "R" ++ (show $ length d)


-- Run Asm computation by passing empty dictionary as initial state,
-- and collecting value and state as a pair.
asm (Asm (SC c)) = c (Env []) $ Res

-- The type parameter of the Asm data type is not used in this
-- implementation of the semantics.  It of course still needs to be
-- there to comply to the structure of Symantics.

-- Think of it like this: since we're mostly interested in making sure
-- that types are correct by _embedding_ the language in a Haskell
-- type class structure, we can strip the types and compile to machine
-- code just fine, making sure that each machine instruction is
-- type-specialized.  In some sense this specialization is the only
-- thing we use the type for.


data Asm t = Asm { unAsm :: SC Res Env Var }

lit x = Asm (return $ show x)


op1 t fn (Asm x) = Asm $ do 
  vx <- x
  op t fn [vx]

op2 t fn (Asm x) (Asm y) = Asm $ do 
  vx <- x
  vy <- y
  op t fn [vx, vy]

op3 t fn (Asm x) (Asm y) (Asm z) = Asm $ do    
  vx <- x
  vy <- y
  vz <- z
  op t fn [vx, vy, vz]

-- The packing & unpacking here is a bit clumsy.  

-- The idea is that the computation is only executed once, and further
-- referred to by a varaiable.  This would not be the case for an
-- ordinary let expression which would run a computation multiple
-- times. (FIXME: explain better).
let' (Asm x) body = Asm $ do
  vx <- x
  unAsm $ body $ Asm $ return vx


{-
showOp (Op fn as) = concat (fn:(map (" "++) as))
showBinding (v,o) = v ++ " = " ++ showOp o
showDict :: (Var,Dict) -> String
showDict (v,d) =
  (concat $ map ((++"\n") . showBinding) (reverse d)) 
  ++ "return " ++ v
-}

-- Note that the type is a _function_, not an atomic value.  To give
-- it a meaning for show we evaluate it using `ssa' which passes in an
-- empty dictionary.  Equality however is not supported (this should
-- be mapped to Symantics Eq operation).
  
instance Show (Asm t) where  show = show . asm
instance Eq (Asm t)   where  (==) a b = False

op1i = op1 "i"
op2i = op2 "i"

op1f = op1 "f"
op2f = op2 "f"

instance Symantics Asm where
  iVal  = lit
  fVal  = lit
  bVal  = lit
  
  isign = op1i "isign"
  iabs  = op1i "iabs"
  
  iadd  = op2i "iadd"
  isub  = op2i "isub"
  imul  = op2i "imul"
  idiv  = op2i "idiv"
  imod  = op2i "imod"
          
  fsign = op1f "fsign"
  fabs  = op1f "fabs"
  
  fadd  = op2f "fadd"
  fsub  = op2f "fsub"  
  fmul  = op2f "fmul"  
  fdiv  = op2f "fdiv"
  
  fsin  = op1f "fsin"
  fcos  = op1f "fcos"
  fexp  = op1f "fexp"

  i2f   = op1f "i2f"                        
  f2i   = op1i "f2i"

  if_   = op3 "?" "if_"
  ieq   = op2i "ieq"
  feq   = op2f "feq"          
          
          
-- FIXME: too much sharing when enabled, too little when not.
  let_  = let'