1%if false 2 Copyright (c) 2009 ETH Zurich. 3 All rights reserved. 4 5 This file is distributed under the terms in the attached LICENSE file. 6 If you do not find this file, copies can be found by writing to: 7 ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group. 8%endif 9 10%include polycode.fmt 11 12 13%if false 14 15> module Constructs.References where 16 17> import Text.PrettyPrint.HughesPJ as Pprinter 18> import Data.Maybe 19 20> import Semantics 21> import Constructs 22> import PureExpressions 23> import {-# SOURCE #-} Expressions 24 25> import IL.FoF.FoF 26> import IL.FoF.Compile 27 28%endif 29 30\section{Reference Cells} 31\label{chap:references} 32 33The reference cell construct provides an abstraction to both variables 34and C pointers. It composed by three combinators to create, read from, 35and write to reference cells. It can be compared to OCaml references 36or Haskell @IORef@. 37 38\subsection{Smart Constructors} 39 40A reference cell is created in an initialized state. The variant 41|newRefN| allows the DSL designer to provide a name to the created 42variable. 43 44> newRef :: Data -> FoFCode Loc 45> newRef d = inject (NewRef Nothing d return) 46> 47> newRefN :: String -> Data -> FoFCode Loc 48> newRefN name d = inject (NewRef (Just name) d return) 49 50Follow primitives to read from and write to these reference cells: 51 52> readRef :: Loc -> FoFCode Data 53> readRef l = inject (ReadRef l return) 54> 55> writeRef :: Loc -> Data -> FoFCode PureExpr 56> writeRef l d = inject (WriteRef l d (return Void)) 57 58The current implementation lacks lots of sanity checks: 59\begin{itemize} 60 \item read and Write on CLRef, 61 \item write from and to compatible types, 62 \item do not write local pointers into param/global ones, 63 \item \ldots 64\end{itemize} 65 66 67\subsection{Compile Instantiation} 68 69The compilation is tricky when it comes to computing the pointer 70type. I wouldn't be surprised if some bugs were lying there. This 71concerns |newRef| and |readRef|, which effect on references is not 72trivial. 73 74> compileReferences (NewRef refName ref r) binding = 75> (FStatement (FNewRef publicName ref) cont, 76> binding2) 77> where (publicName, binding1) 78> = case refName of 79> Just x -> (Provided x, binding) 80> Nothing -> 81> let (loc, binding1) = getFreshVar binding in 82> (makeVarName Local loc, binding1) 83> ret = CLRef Local (TPointer (typeOf ref) Avail) publicName 84> (cont, binding2) = r ret binding1 85> 86> compileReferences (ReadRef ref@(CLRef _ _ xloc) r) binding = 87> (FStatement (FReadRef name ref) cont, 88> binding2) 89> where (loc, name, binding1) = heritVarName binding xloc 90> ret = CLRef Local (unfoldPtrType ref) name 91> (cont, binding2) = r ret binding1 92 93|writeRef| is straightforward. 94 95> compileReferences (WriteRef ref d r) binding = 96> (FStatement (FWriteRef ref d) cont, 97> binding1) 98> where (cont, binding1) = r binding 99 100 101\subsection{Run Instantiation} 102 103On the other hand, the implementation of the interpreter is much 104simpler. We start with the dispatcher: 105 106> runReferences (NewRef _ d r) heap = uncurry r $ runNewRef d heap 107> runReferences (ReadRef l r) heap = uncurry r $ runReadRef l heap 108> runReferences (WriteRef l v r) heap = r $ runWriteRef l v heap 109 110And the per-construct interpreters follow: 111 112> runNewRef :: Data -> Heap -> (Loc, Heap) 113> runNewRef value heap = 114> ( CLRef Local typeOfVal name, heap2 ) 115> where typeOfVal = typeOf value 116> loc = freshLoc heap 117> refs = refMap heap 118> name = makeVarName Local loc 119> heap1 = heap { freshLoc = loc + 1 } 120> heap2 = heap1 { refMap = (name, value) : refs } 121> 122> runReadRef :: Loc -> Heap -> (Data, Heap) 123> runReadRef (CLRef _ _ location) heap = 124> let refs = refMap heap in 125> let val = fromJust $ location `lookup` refs in 126> (val, heap) 127> 128> runWriteRef :: Loc -> Data -> Heap -> Heap 129> runWriteRef (CLRef _ _ location) value heap = 130> let refs = refMap heap in 131> let refs1 = (location, value) : refs in 132> heap { refMap = refs1 }