Skip to content

Commit

Permalink
more type-safe paraiso!
Browse files Browse the repository at this point in the history
  • Loading branch information
@nushio3
nushio3 committed Jun 5, 2012
1 parent f79bfab commit 08487c4
Show file tree
Hide file tree
Showing 4 changed files with 111 additions and 65 deletions.
10 changes: 6 additions & 4 deletions Language/Paraiso/OM/Arithmetic.hs
View file
Expand Up @@ -6,7 +6,8 @@ module Language.Paraiso.OM.Arithmetic
Operator(..)
) where

import NumericPrelude hiding (Ordering(..), Eq(..), Ord(..))
import qualified Data.Dynamic as Dynamic
import NumericPrelude hiding (Ordering(..), Eq(..), Ord(..))
import qualified NumericPrelude as P

class Arity a where
Expand Down Expand Up @@ -60,8 +61,9 @@ data Operator =
Acos |
Atan |
Atan2 |
Sincos
deriving (P.Eq, P.Ord, P.Show, P.Read)
Sincos |
Cast Dynamic.TypeRep
deriving (P.Eq, P.Ord, P.Show)

instance Arity Operator where
arity a = case a of
Expand Down Expand Up @@ -105,4 +107,4 @@ instance Arity Operator where
Atan -> (1,1)
Atan2 -> (2,1)
Sincos -> (1,2)

Cast _ -> (1,1)
147 changes: 89 additions & 58 deletions Language/Paraiso/OM/Builder/Internal.hs
View file
Expand Up @@ -166,13 +166,11 @@ bind = fmap return

-- | Load from a static value.
load :: (TRealm r, Typeable c) =>
Named (Val.Value r c) -- the named static value to be loaded.
-> B (Value r c) -- ^The loaded 'TArray' 'Value' as a result.
load (Named name0 val0)= do
Named (Val.StaticValue r c) -- ^ the named static value to be loaded from.
-> B (Value r c) -- ^ The loaded 'Value' as a result.
load (Named name0 (Val.StaticValue r0 c0))= do
let
r0 = Val.realm val0
c0 = Val.content val0
type0 = toDyn val0
type0 = mkDyn r0 c0
nv = Named name0 type0
idx <- lookUpStatic nv
n0 <- addNodeE [] $ NInst (Load idx)
Expand All @@ -181,10 +179,10 @@ load (Named name0 val0)= do

-- | Store to a static value.
store :: (TRealm r, Typeable c) =>
Name -- ^The 'Name' of the static value to store.
-> Builder v g a (Value r c) -- ^The 'Value' to be stored.
-> Builder v g a () -- ^The result.
store name0 builder0 = do
Named (Val.StaticValue r c) -- ^ the named static value to be stored on.
-> Builder v g a (Value r c) -- ^ The 'Value' to be stored.
-> Builder v g a () -- ^ The result.
store (Named name0 _) builder0 = do
val0 <- builder0
let
type0 = toDyn val0
Expand Down Expand Up @@ -243,27 +241,30 @@ shift vec builder1 = do
return (FromNode TArray c1 n3)

-- | Load the 'Axis' component of the mesh address, to a 'TArray' 'Value'.
loadIndex :: (Typeable c) =>
c -- ^The 'Val.content' type.
-> Axis v -- ^ The axis for which index is required
-> Builder v g a (Value TArray c) -- ^ The 'TArray' 'Value' that contains the address as a result.
loadIndex c0 axis = do
let type0 = mkDyn TArray c0
loadIndex :: (Typeable g)
=> Axis v -- ^ The axis for which index is required
-> Builder v g a (Value TArray g) -- ^ The 'TArray' 'Value' that contains the address as a result.
loadIndex axis = do
-- create a phantom object of type g
c0 <- (return undefined) `asTypeOf` (fmap Val.content $ loadIndex axis)
let
type0 = mkDyn TArray c0
n0 <- addNodeE [] $ NInst (LoadIndex axis)
n1 <- addNodeE [n0] $ NValue type0
return (FromNode TArray c0 n1)

-- | Load the 'Axis' component of the mesh size, to either a 'TScalar' 'Value' or 'TArray' 'Value'..
loadSize :: (TRealm r, Typeable c)
=> r -- ^ The 'TRealm'
-> c -- ^The 'Val.content' type.
-> Axis v -- ^ The axis for which the size is required
-> Builder v g a (Value r c) -- ^ The 'TScalar' 'Value' that contains the size of the mesh in that direction.
loadSize r0 c0 axis = do
let type0 = mkDyn r0 c0
loadSize :: (Typeable g)
=> Axis v -- ^ The axis for which the size is required
-> Builder v g a (Value TScalar g) -- ^ The 'TScalar' 'Value' that contains the size of the mesh in that direction.
loadSize axis = do
-- create a phantom object of type g
c0 <- (return undefined) `asTypeOf` (fmap Val.content $ loadSize axis)
let
type0 = mkDyn TScalar c0
n0 <- addNodeE [] $ NInst (LoadSize axis)
n1 <- addNodeE [n0] $ NValue type0
return (FromNode r0 c0 n1)
return (FromNode TScalar c0 n1)


-- | Create an immediate 'Value' from a Haskell concrete value.
Expand All @@ -273,6 +274,13 @@ imm :: (TRealm r, Typeable c) =>
-> B (Value r c) -- ^'TArray' 'Value' with the @c@ stored.
imm c0 = return (FromImm unitTRealm c0)



----------------------------------------------------------------
-- Here comes the Arith instruction emitters.
----------------------------------------------------------------


-- | Make a unary operator
mkOp1 :: (TRealm r, Typeable c) =>
A.Operator -- ^The operator symbol
Expand Down Expand Up @@ -307,40 +315,6 @@ mkOp2 op builder1 builder2 = do
return $ FromNode r1 c1 n01


-- | Execute the builder under modifed annotation.
withAnnotation :: (a -> a) -> Builder v g a ret -> Builder v g a ret
withAnnotation f builder1 = do
stat0 <- State.get
let curAnot0 = currentAnnotation (context stat0)
curAnot1 = f curAnot0
State.put $ stat0{ context = (context stat0){ currentAnnotation = curAnot1 } }
ret <- builder1
stat1 <- State.get
State.put $ stat1{ context = (context stat1){ currentAnnotation = curAnot0} }
return ret


-- | Execute the builder, and annotate the very result with the givin function.
annotate :: (TRealm r, Typeable c) => (a -> a) -> Builder v g a (Value r c) -> Builder v g a (Value r c)
annotate f builder1 = do
v1 <- builder1
n1 <- valueToNode v1
let
r1 = Val.realm v1
c1 = Val.content v1
annotator con@(ins, n2, node2, outs)
| n1 /= n2 = con
| otherwise = (ins, n2, fmap f node2, outs)
stat0 <- State.get
State.put $ stat0 {
target = FGL.gmap annotator (target stat0)
}
return $ FromNode r1 c1 n1

-- | (<?>) = annotate
infixr 0 <?>
(<?>) :: (TRealm r, Typeable c) => (a -> a) -> Builder v g a (Value r c) -> Builder v g a (Value r c)
(<?>) = annotate

-- | Builder is Additive 'Additive.C'.
-- You can use 'Additive.zero', 'Additive.+', 'Additive.-', 'Additive.negate'.
Expand Down Expand Up @@ -370,6 +344,8 @@ instance (TRealm r, Typeable c, Ring.C c) => Ring.C (Builder v g a (Value r c))
bx_n3 <- fmap return $ f x n3
modify $ bx_n3*bx_n3

-- Here comes the Arith node creaters.

-- | Builder is Ring 'IntegralDomain.C'.
-- You can use div and mod.
instance (TRealm r, Typeable c, IntegralDomain.C c) => IntegralDomain.C (Builder v g a (Value r c)) where
Expand Down Expand Up @@ -438,3 +414,58 @@ instance (TRealm r, Typeable c, Transcendental.C c) =>
asin = mkOp1 A.Asin
acos = mkOp1 A.Acos
atan = mkOp1 A.Atan

-- | A special Arith operation that keeps the realm and casts the content
-- from one type to another.
cast :: (TRealm r, Typeable c1,Typeable c2) => (Builder v g a (Value r c1)) -> (Builder v g a (Value r c2))
cast builder1 = do
-- create a phantom object of type c2
v1 <- builder1
c2 <- return undefined `asTypeOf` (fmap Val.content $ cast builder1)
let
r1 = Val.realm v1
c1 = Val.content v1
n1 <- valueToNode v1
n0 <- addNodeE [n1] $ NInst (Arith $ A.Cast $ Dynamic.typeOf c2)
n01 <- addNodeE [n0] $ NValue (toDyn v1)
return $ FromNode r1 c2 n01





-- | Execute the builder under modifed annotation.
withAnnotation :: (a -> a) -> Builder v g a ret -> Builder v g a ret
withAnnotation f builder1 = do
stat0 <- State.get
let curAnot0 = currentAnnotation (context stat0)
curAnot1 = f curAnot0
State.put $ stat0{ context = (context stat0){ currentAnnotation = curAnot1 } }
ret <- builder1
stat1 <- State.get
State.put $ stat1{ context = (context stat1){ currentAnnotation = curAnot0} }
return ret


-- | Execute the builder, and annotate the very result with the givin function.
annotate :: (TRealm r, Typeable c) => (a -> a) -> Builder v g a (Value r c) -> Builder v g a (Value r c)
annotate f builder1 = do
v1 <- builder1
n1 <- valueToNode v1
let
r1 = Val.realm v1
c1 = Val.content v1
annotator con@(ins, n2, node2, outs)
| n1 /= n2 = con
| otherwise = (ins, n2, fmap f node2, outs)
stat0 <- State.get
State.put $ stat0 {
target = FGL.gmap annotator (target stat0)
}
return $ FromNode r1 c1 n1

-- | (<?>) = annotate
infixr 0 <?>
(<?>) :: (TRealm r, Typeable c) => (a -> a) -> Builder v g a (Value r c) -> Builder v g a (Value r c)
(<?>) = annotate

14 changes: 12 additions & 2 deletions Language/Paraiso/OM/DynValue.hs
View file
Expand Up @@ -20,9 +20,19 @@ data DynValue = DynValue {realm :: R.Realm, typeRep :: TypeRep} deriving (Eq, Sh
mkDyn :: (R.TRealm r, Typeable c) => r -> c -> DynValue
mkDyn r0 c0 = DynValue (R.tRealm r0) (typeOf c0)


-- | Something that can be converted to 'DynValue'
class ToDynable a where
toDyn :: a -> DynValue

-- | Convert 'Val.Value' to 'DynValue'
toDyn :: (R.TRealm r, Typeable c) => Val.Value r c -> DynValue
toDyn x = mkDyn (Val.realm x) (Val.content x)
instance (R.TRealm r, Typeable c) => ToDynable (Val.Value r c) where
toDyn x = mkDyn (Val.realm x) (Val.content x)

-- | Convert 'Val.StaticValue' to 'DynValue'
instance (R.TRealm r, Typeable c) => ToDynable (Val.StaticValue r c) where
toDyn (Val.StaticValue r c) = mkDyn r c


instance R.Realmable DynValue where
realm = realm
5 changes: 4 additions & 1 deletion Language/Paraiso/OM/Value.hs
View file
Expand Up @@ -6,7 +6,7 @@

module Language.Paraiso.OM.Value
(
Value(..)
Value(..), StaticValue(..)
) where

import Data.Typeable
Expand All @@ -27,6 +27,9 @@ data
-- 'content' is the immediate value to be stored.
FromImm {realm :: rea, content :: con} deriving (Eq, Show)

-- | static value type.
data StaticValue rea con = StaticValue rea con deriving (Eq, Show)


instance (R.TRealm rea, Typeable con) => R.Realmable (Value rea con) where
realm (FromNode r _ _) = R.tRealm r
Expand Down

0 comments on commit 08487c4

Please sign in to comment.