New patches: [clean up foreignptr implementation some. John Meacham **20120206181122 Ignore-this: 17b7146d0bab97deb69e907f67c61af1 ] hunk ./lib/base/Foreign/ForeignPtr.hs 30 addForeignPtrFinalizer finalizer fp return fp --- newForeignPtrEnv :: FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a) addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO () addForeignPtrFinalizer _ _ = return () hunk ./lib/base/Foreign/ForeignPtr.hs 33 --- addForeignPtrFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO () - -mallocForeignPtr :: Storable a => IO (ForeignPtr a) -mallocForeignPtr = liftM FP malloc - mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) hunk ./lib/base/Foreign/ForeignPtr.hs 34 -mallocForeignPtrBytes = liftM FP . mallocBytes +mallocForeignPtrBytes x = do + ptr <- mallocBytes x + newForeignPtr finalizerFree ptr hunk ./lib/base/Foreign/ForeignPtr.hs 38 +mallocForeignPtr :: Storable a => IO (ForeignPtr a) +mallocForeignPtr = doMalloc undefined where + doMalloc :: Storable b => b -> IO (ForeignPtr b) + doMalloc x = mallocForeignPtrBytes (sizeOf x) + mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a) hunk ./lib/base/Foreign/ForeignPtr.hs 44 -mallocForeignPtrArray = liftM FP . mallocArray +mallocForeignPtrArray = doMalloc undefined where + doMalloc :: Storable a' => a' -> Int -> IO (ForeignPtr a') + doMalloc dummy size = mallocForeignPtrBytes (size * sizeOf dummy) mallocForeignPtrArray0 :: Storable a => Int -> IO (ForeignPtr a) hunk ./lib/base/Foreign/ForeignPtr.hs 49 -mallocForeignPtrArray0 = liftM FP . mallocArray0 - --- mallocForeignPtrArray0 :: Storable a => Int -> IO (ForeignPtr a) --- mallocForeignPtrArray0 = liftM FP . mallocArray0 +mallocForeignPtrArray0 sz = mallocForeignPtrArray (sz + 1) withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b hunk ./lib/base/Foreign/ForeignPtr.hs 52 -withForeignPtr (FP p) act = act p +withForeignPtr fp act = do + r <- act (unsafeForeignPtrToPtr fp) + touchForeignPtr fp + return r unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a unsafeForeignPtrToPtr (FP x) = x hunk ./lib/base/Foreign/ForeignPtr.hs 63 touchForeignPtr :: ForeignPtr a -> IO () touchForeignPtr _ = return () +--foreign import primitive "touch_" :: ForeignPtr a -> + castForeignPtr :: ForeignPtr a -> ForeignPtr b castForeignPtr (FP x) = FP $ castPtr x hunk ./lib/base/Foreign/ForeignPtr.hs 71 -- |A finalizer is represented as a pointer to a foreign function that, at -- finalisation time, gets as an argument a plain pointer variant of the -- foreign pointer that the finalizer is associated with. --- type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ()) -- | This variant of newForeignPtr adds a finalizer that expects an environment in addition to the finalized pointer. The environment that will be passed to the finalizer is fixed by the second argument to newForeignPtrEnv. hunk ./lib/base/Foreign/ForeignPtr.hs 75 newForeignPtrEnv :: FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a) -newForeignPtrEnv _ _ p = newForeignPtr_ p +newForeignPtrEnv f e p = do + fp <- newForeignPtr_ p + addForeignPtrFinalizerEnv f e fp + return fp -- | Like addForeignPtrFinalizerEnv but allows the finalizer to be passed an additional environment parameter to be passed to the finalizer. The environment passed to the finalizer is fixed by the second argument to addForeignPtrFinalizerEnv addForeignPtrFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO () hunk ./lib/jhc/Foreign/Marshal/Array.hs 50 advancePtr, -- :: Storable a => Ptr a -> Int -> Ptr a ) where - import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr hunk ./lib/jhc/Foreign/Marshal/Array.hs 105 reallocArray0 :: Storable a => Ptr a -> Int -> IO (Ptr a) reallocArray0 ptr size = reallocArray ptr (size + 1) - -- |Convert an array of given length into a Haskell list. This version -- traverses the array backwards using an accumulating parameter, -- which uses constant stack space. The previous version using mapM hunk ./lib/jhc/Foreign/Marshal/Array.hs 127 -- finding the length -- ------------------ - -- |Write the list elements consecutive into memory -- --pokeArray :: Storable a => Ptr a -> [a] -> IO () hunk ./lib/jhc/Foreign/Marshal/Array.hs 142 f n [] | n `seq` True = return n f n (x:xs) = pokeElemOff ptr n x >> f (n + 1) xs - -- |Write the list elements consecutive into memory and terminate them with the -- given marker element -- hunk ./lib/jhc/Foreign/Marshal/Array.hs 206 where len = length vals - -- copying (argument order: destination, source) -- ------- hunk ./lib/jhc/Foreign/Marshal/Array.hs 227 doMove :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO () doMove dummy dest src size = moveBytes dest src (size * sizeOf dummy) - -- finding the length -- ------------------ hunk ./lib/jhc/Foreign/Marshal/Array.hs 239 val <- peekElemOff ptr i if val == marker then return i else loop (i+1) - -- indexing -- -------- hunk ./regress/tests/0_parse/config.yaml 1 -jhc_flags: --stop parse --stale Main --no-ho +jhc_flags: --stop parse --stale Main --no-cache run: no hunk ./regress/tests/1_typecheck/config.yaml 1 -jhc_flags: --stop typecheck --stale Main --no-ho +jhc_flags: --stop typecheck --stale Main --no-cache run: no hunk ./rts/jhc_jgc.c 201 number_gcs, number_allocs, (unsigned)arena->block_used, - block_threshold, + (unsigned)arena->block_threshold, number_stack, number_ptr, number_redirects, hunk ./rts/slub.c 120 /* block allocator */ -static unsigned block_threshold = 8; - static struct s_block * get_free_block(gc_t gc, struct s_arena *arena) { arena->block_used++; [add Jhc.Prim.Rts to access properties of the RTS John Meacham **20120207015719 Ignore-this: be65a8819515ab079e2ddbd28914bed7 ] addfile ./lib/jhc-prim/Jhc/Prim/Array.hs hunk ./lib/jhc-prim/Jhc/Prim/Array.hs 1 +module Jhc.Prim.Array where + +import Jhc.Prim.IO +import Jhc.Prim.Bits + +data MutArray_ :: * -> # +newtype Array_ m = Array_ (MutArray_ m) + +foreign import primitive newArray__ :: Word_ -> a -> UST s (MutArray_ a) +foreign import primitive newBlankArray__ :: Word_ -> UST s (MutArray_ a) +foreign import primitive copyArray__ :: Word_ -> Word_ -> Word_ -> MutArray_ a -> MutArray_ a -> UST_ s +foreign import primitive readArray__ :: MutArray_ a -> Word_ -> UST s a +foreign import primitive writeArray__ :: MutArray_ a -> Word_ -> a -> UST_ s +foreign import primitive indexArray__ :: Array_ a -> Word_ -> (# a #) addfile ./lib/jhc-prim/Jhc/Prim/Rts.hs hunk ./lib/jhc-prim/Jhc/Prim/Rts.hs 1 +-- allowing introspection into the rts +module Jhc.Prim.Rts where + +import Jhc.Prim.Bits + +--data Void + +-- A Bang_ is always in WHNF. The mnemonic is 'Bang_ Char ~ !Char' +-- toBang_ will seq the object if needed. +data Bang_ a :: # -- TODO(jwm): should be '!' + +foreign import primitive toBang_ :: a -> Bang_ a +foreign import primitive fromBang_ :: Bang_ a -> a +foreign import primitive isWHNF :: a -> Bool_ +foreign import primitive isInHeap :: Bang_ a -> Bool_ +foreign import primitive bangBits :: Bang_ a -> BitsPtr_ +foreign import primitive bangPtr :: Bang_ a -> Addr_ + +--isWHNF :: a -> Bool_ +--isInHeap :: Bang_ a -> Bool_ +--bangBits :: Bang_ a -> BitsPtr_ hunk ./lib/jhc-prim/jhc-prim.yaml 7 Options: --noauto Hs-Source-Dir: . Exposed-Modules: - - Jhc.Prim.Bits - Jhc.Prim.Array hunk ./lib/jhc-prim/jhc-prim.yaml 8 + - Jhc.Prim.Bits - Jhc.Prim.IO - Jhc.Prim.Prim hunk ./lib/jhc-prim/jhc-prim.yaml 11 + - Jhc.Prim.Rts - Jhc.Prim.Wrapper hunk ./src/E/PrimDecode.hs 47 utup ~([] :-> t1) ~([] :-> t2) = [] :-> BTup [t1,t2] utup1 ~([] :-> t1) = [] :-> BTup [t1] array = hash +bang = hash infixr 3 +> (+>) :: Typ -> Typ -> Typ hunk ./src/E/PrimDecode.hs 68 , "one" ==> starHash , "box" ==> hash +> star , "unbox" ==> star +> hash - , "constPeekByte" ==> hash +> hash , "exitFailure__" ==> hash +> hash hunk ./src/E/PrimDecode.hs 69 + , "constPeekByte" ==> hash +> hash + -- array operations , "newArray__" ==> hash +> star +> state +> utup state array , "newBlankArray__"==> hash +> state +> utup state array , "copyArray__" ==> hash +> hash +> hash +> array +> array +> state +> state hunk ./src/E/PrimDecode.hs 77 , "readArray__" ==> array +> hash +> state +> utup state star , "writeArray__" ==> array +> hash +> star +> state +> state , "indexArray__" ==> array +> hash +> utup1 star + -- accessing the rts directly + , "toBang_" ==> star +> bang + , "fromBang_" ==> bang +> star + , "isWHNF" ==> star +> hash + , "isInHeap" ==> bang +> hash + , "bangPtr" ==> bang +> hash + , "bangBits" ==> bang +> hash ] `Map.union` fmap (const (starHash +> starHash)) incDec `Map.union` fmap (const star) primBoundMap hunk ./src/data/names.txt 6 IOErrorType Jhc.Type.Handle.IOErrorType IOMode Jhc.Type.Handle.IOMode +Bang_ Jhc.Prim.Rts.Bang_ Arrow Jhc.Prim.Prim.-> MutArray__ Jhc.Prim.Array.MutArray_ List Jhc.Prim.Prim.[] [add support for 'Coerce' grin primitive, add atomic allocs in grin. John Meacham **20120207063202 Ignore-this: 64eab2e8901db764df62b6fcd471b6b7 ] hunk ./lib/base/Foreign/ForeignPtr.hs 15 import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable +import Jhc.IO newtype ForeignPtr a = FP (Ptr a) deriving(Eq,Ord) hunk ./lib/base/Foreign/ForeignPtr.hs 62 unsafeForeignPtrToPtr (FP x) = x touchForeignPtr :: ForeignPtr a -> IO () -touchForeignPtr _ = return () +touchForeignPtr x = fromUIO_ (touch_ x) hunk ./lib/base/Foreign/ForeignPtr.hs 64 ---foreign import primitive "touch_" :: ForeignPtr a -> +foreign import primitive touch_ :: ForeignPtr a -> UIO_ castForeignPtr :: ForeignPtr a -> ForeignPtr b castForeignPtr (FP x) = FP $ castPtr x addfile ./rts/rts_constants.h hunk ./rts/rts_constants.h 1 +#ifndef RTS_CONSTANTS_H +#define RTS_CONSTANTS_H +/* these constants are shared between jhc-prim and the rts. */ + +// Normal memory block. +#define SLAB_FLAG_NONE 0 + +// Each element has a finalizer-list as its second word. +#define SLAB_FLAG_FINALIZER 1 + +// In addition to whatever other finalization is done, 'free' should be called +// on the first word of each entry. +#define SLAB_FLAG_FREE 2 + +// Finalizers should be delayed until entire slab is freed up and individually +// freed members need not be kept track of. +#define SLAB_FLAG_DELAY 4 + +#endif hunk ./rts/slub.c 52 unsigned char color; unsigned char size; unsigned char num_ptrs; + unsigned char flags; }; struct s_block { hunk ./rts/slub.c 279 sc->arena = arena; sc->pi.size = size; sc->pi.num_ptrs = num_ptrs; + sc->pi.flags = FLAG_NONE; size_t excess = BLOCK_SIZE - sizeof(struct s_block); sc->num_entries = (8*excess) / (8*sizeof(uintptr_t)*size + 1) - 1; //sc->num_entries = (8*excess) / (8*size*sizeof(uintptr_t) + 1); hunk ./src/C/FromGrin2.hs 441 v <- g t return (jerr & creturn v) -convertBody (BaseOp (StoreNode b) [n@NodeC {}]) = newNode region_heap (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v) -convertBody (BaseOp (StoreNode b) [n@NodeC {},region]) = newNode region (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v) +convertBody (BaseOp (StoreNode b) [n@NodeC {}]) = newNode region_heap (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v) +convertBody (BaseOp (StoreNode b) [n@NodeC {},region]) = newNode region (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v) convertBody (e :>>= [(Var vn _)] :-> e') | vn == v0 = do ss <- localTodo TodoNothing (convertBody e) hunk ./src/C/FromGrin2.hs 481 base <- convertVal base z' <- convertVal z return $ indexArray base (constant $ number 0) =* z' ---convertBody (Update (Index base off) z) | getType base == TyPtr tyINode = do --- base <- convertVal base --- off <- convertVal off --- z' <- convertVal z --- return $ indexArray base off =* z' convertBody (BaseOp PeekVal [Index base off]) | getType base == TyPtr tyINode = do base <- convertVal base off <- convertVal off hunk ./src/C/FromGrin2.hs 485 simpleRet (indexArray base off) - +convertBody (BaseOp (Coerce ty) [v]) = do + v <- convertVal v + ty <- convertType ty + simpleRet $ cast ty v convertBody (GcRoots vs b) = do vs <- mapM convertVal vs b' <- convertBody b hunk ./src/C/FromGrin2.hs 605 i <- newVar (basicType "int") return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i =* v' return (malloc `mappend` fill, tmp) +convertExp Alloc { expValue = v, expCount = c, expRegion = r } | + r == region_atomic_heap, TyPrim Op.bits_ptr == getType v = do + v' <- convertVal v + c' <- convertVal c + tmp <- newVar (ptrType uintptr_t) + let malloc = tmp =* jhc_malloc_atomic (operator "*" (sizeof uintptr_t) c') + fill <- case v of + ValUnknown _ -> return mempty + _ -> do + i <- newVar (basicType "int") + return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i =* v' + return (malloc `mappend` fill, tmp) convertExp e = return (err (show e),err "nothing") hunk ./src/C/FromGrin2.hs 908 lvs -> functionCall (name "gc_frame0") (v_gc:constant (number (fromIntegral lvs)):vs) gc_end = functionCall (name "gc_end") [] tbsize sz = functionCall (name "TO_BLOCKS") [sz] + +jhc_malloc_atomic sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,nullPtr, tbsize sz, toExpression (0::Int)] + | otherwise = jhc_malloc nullPtr (0::Int) sz + jhc_malloc ntn nptrs sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,ntn, tbsize sz, toExpression nptrs] -- | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,tbsize sz, toExpression nptrs] jhc_malloc _ 0 sz = functionCall (name "jhc_malloc_atomic") [sz] hunk ./src/C/FromGrin2.hs 953 nodeFuncName a = toName (fromAtom a) sptr_t = basicGCType "sptr_t" +uintptr_t = basicGCType "uintptr_t" fptr_t = basicGCType "fptr_t" wptr_t = basicGCType "wptr_t" gc_t = basicGCType "gc_t" hunk ./src/Grin/FromE.hs 68 unboxedMap :: [(Name,Ty)] unboxedMap = [ (tc_State_,TyUnit), - (tc_MutArray__,TyPtr tyINode) + (tc_MutArray__,TyPtr tyINode), + (tc_Bang_,tyDNode) ] newtype C a = C (ReaderT LEnv IO a) hunk ./src/Grin/FromE.hs 427 f "writeArray__" [r,o,v,_] = do let [r',o',v'] = args [r,o,v] return $ BaseOp PokeVal [(Index r' o'),v'] + -- rts + f "toBang_" (args -> [x]) = do + return $ gEval x + f "fromBang_" [x] = do + return (BaseOp Demote $ args [x]) + f "mallocHeapWords" [w,_] = do + let [c] = args [w] + v <- newPrimVar (TyPtr (TyPrim Op.bits_ptr)) + return $ Alloc { expValue = ValUnknown (TyPrim Op.bits_ptr), + expCount = c, expRegion = region_atomic_heap, expInfo = mempty } :>>= [v] :-> BaseOp (Coerce tyDNode) [v] f p xs = fail $ "Grin.FromE - Unknown primitive: " ++ show (p,xs) -- other primitives hunk ./src/Grin/Grin.hs 107 | PokeVal -- write a value to a pointed to location | Consume -- consume a value, depending on the back end this may be used to free memory | GcTouch -- touch a value, forcing the GC to hold onto it. + | Coerce Ty -- coerce one type to another, danger zone. This is for reflection/rts and not for integral conversions. | GcPush -- push some pointers onto the GC stack, returning registers representing the values on the stack | NewRegister -- create a new register | ReadRegister -- read a register hunk ./src/Grin/Grin.hs 453 getType App { expType = t } = t getType (BaseOp Overwrite _) = [] getType (BaseOp GcTouch _) = [] + getType (BaseOp (Coerce t) _) = [t] getType (BaseOp Redirect _) = [] getType (BaseOp Promote _) = [TyNode] getType (BaseOp Demote _) = [TyINode] hunk ./src/Grin/Show.hs 75 prettyExp vl (Error "" _) = vl <> prim "exitFailure" prettyExp vl (Error s _) = vl <> keyword "error" <+> tshow s prettyExp vl (BaseOp Eval [v]) = vl <> keyword "eval" <+> prettyVal v +prettyExp vl (BaseOp Coerce {} [v]) = vl <> keyword "coerce" <+> prettyVal v prettyExp vl (BaseOp Apply {} vs) = vl <> keyword "apply" <+> hsep (map prettyVal vs) prettyExp vl (App a vs _) = vl <> func (fromAtom a) <+> hsep (map prettyVal vs) prettyExp vl Prim { expPrimitive = APrim (Op (Op.BinOp bo _ _) _) _, expArgs = [x,y] } | Just (op,_) <- Op.binopInfix bo = vl <> prettyVal x <+> operator op <+> prettyVal y hunk ./src/Grin/Val.hs 11 cInt, convertName, region_heap, + region_atomic_heap, region_stack, region_block ) where hunk ./src/Grin/Val.hs 36 -- This allocates data on the heap. region_heap = Item (toAtom "heap") TyRegion +-- This allocates data on the atomic heap. +region_atomic_heap = Item (toAtom "atomicHeap") TyRegion -- This allocates data in the innermost enclosing region, including implicit regions. region_block = Item (toAtom "block") TyRegion -- This allocates data on the stack, generally equivalent to 'block' for most back ends. hunk ./src/Ho/Binary.hs 22 import Support.MapBinaryInstance current_version :: Int -current_version = 8 +current_version = 9 readHFile :: FilePath -> IO (FilePath,HoHeader,forall a . Binary a => ChunkType -> a) readHFile fn = do [make foreign imports work with unboxed IO types, improve primitive operators. John Meacham **20120207105510 Ignore-this: b43075dce20079f7892e7f0f0c0abb66 ] hunk ./lib/base/Foreign/StablePtr.hs 1 -{-# OPTIONS_JHC -fno-prelude -fffi #-} +{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-tuples #-} module Foreign.StablePtr( StablePtr(), castStablePtrToPtr, hunk ./lib/base/Foreign/StablePtr.hs 11 freeStablePtr ) where -import Jhc.Addr +import Jhc.Prim.Rts +import Jhc.IO +import Jhc.Type.Ptr import Jhc.Basics hunk ./lib/base/Foreign/StablePtr.hs 15 -import Jhc.Monad hunk ./lib/base/Foreign/StablePtr.hs 16 -newtype StablePtr a = StablePtr (Ptr ()) -data PlaceHolder +data StablePtr a castPtrToStablePtr :: Ptr () -> StablePtr a hunk ./lib/base/Foreign/StablePtr.hs 19 -castPtrToStablePtr p = StablePtr p +castPtrToStablePtr (Ptr (Addr_ p)) = fromBang_ (bangFromRaw p) castStablePtrToPtr :: StablePtr a -> Ptr () hunk ./lib/base/Foreign/StablePtr.hs 22 -castStablePtrToPtr (StablePtr p) = p - +castStablePtrToPtr p = Ptr (Addr_ (bangToRaw (toBang_ p))) freeStablePtr :: StablePtr a -> IO () hunk ./lib/base/Foreign/StablePtr.hs 25 -freeStablePtr _ = return () +freeStablePtr p = c_freeStablePtr (toBang_ p) hunk ./lib/base/Foreign/StablePtr.hs 27 +-- | newStablePtr will seq its argument to get rid of nasty GC issues and be +-- compatible with FFI calling conventions, if this is an issue, you can put an +-- extra box around it. newStablePtr :: a -> IO (StablePtr a) newStablePtr x = do hunk ./lib/base/Foreign/StablePtr.hs 32 - ptr <- ref_ptr (unsafeCoerce x) - return (StablePtr ptr) + fromUIO $ \w -> case c_newStablePtr (toBang_ x) w of + (# w', s #) -> (# w', fromBang_ s #) deRefStablePtr :: StablePtr a -> IO a hunk ./lib/base/Foreign/StablePtr.hs 36 -deRefStablePtr (StablePtr x) = do - v <- deref_ptr x - return (unsafeCoerce v) - -deref_ptr = undefined -ref_ptr = undefined -unsafeCoerce = undefined - -{- - -foreign import primitive deref_ptr :: Ptr () -> IO PlaceHolder -foreign import primitive ref_ptr :: PlaceHolder -> IO (Ptr ()) +deRefStablePtr x = do + fromUIO $ \w -> case c_derefStablePtr (toBang_ x) w of + (# w', s #) -> (# w', fromBang_ s #) hunk ./lib/base/Foreign/StablePtr.hs 40 -foreign import primitive unsafeCoerce :: a -> b --} +foreign import ccall unsafe "rts/stableptr.c c_freeStablePtr" c_freeStablePtr :: Bang_ (StablePtr a) -> IO () +foreign import ccall unsafe "rts/stableptr.c c_newStablePtr" c_newStablePtr :: Bang_ a -> UIO (Bang_ (StablePtr a)) +foreign import ccall unsafe "rts/stableptr.c c_derefStablePtr" c_derefStablePtr :: Bang_ (StablePtr a) -> UIO (Bang_ a) hunk ./lib/jhc-prim/Jhc/Prim/Rts.hs 6 import Jhc.Prim.Bits ---data Void - -- A Bang_ is always in WHNF. The mnemonic is 'Bang_ Char ~ !Char' hunk ./lib/jhc-prim/Jhc/Prim/Rts.hs 7 --- toBang_ will seq the object if needed. -data Bang_ a :: # -- TODO(jwm): should be '!' - -foreign import primitive toBang_ :: a -> Bang_ a -foreign import primitive fromBang_ :: Bang_ a -> a -foreign import primitive isWHNF :: a -> Bool_ -foreign import primitive isInHeap :: Bang_ a -> Bool_ -foreign import primitive bangBits :: Bang_ a -> BitsPtr_ -foreign import primitive bangPtr :: Bang_ a -> Addr_ +-- Bang_ is also an FFI-able type that turns into a raw haskell object pointer. +data Bang_ a :: # hunk ./lib/jhc-prim/Jhc/Prim/Rts.hs 10 ---isWHNF :: a -> Bool_ ---isInHeap :: Bang_ a -> Bool_ ---bangBits :: Bang_ a -> BitsPtr_ +-- safe +foreign import primitive toBang_ :: a -> Bang_ a +foreign import primitive fromBang_ :: Bang_ a -> a +-- unwise +foreign import primitive isWHNF :: a -> Bool_ +foreign import primitive isInHeap :: Bang_ a -> Bool_ +foreign import primitive bangPtr :: Bang_ a -> Addr_ +foreign import primitive bangToRaw :: Bang_ a -> BitsPtr_ +-- unsafe +foreign import primitive bangFromRaw :: BitsPtr_ -> Bang_ a hunk ./rts/slub.c 279 sc->arena = arena; sc->pi.size = size; sc->pi.num_ptrs = num_ptrs; - sc->pi.flags = FLAG_NONE; + sc->pi.flags = 0; size_t excess = BLOCK_SIZE - sizeof(struct s_block); sc->num_entries = (8*excess) / (8*sizeof(uintptr_t)*size + 1) - 1; //sc->num_entries = (8*excess) / (8*size*sizeof(uintptr_t) + 1); hunk ./src/DataConstructors.hs 380 f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as) f _ = fail "extractIO: not an IO type" -extractIO' :: E -> (Bool,E) -extractIO' e = case extractIO e of - Just x -> (True,x) - Nothing -> (False,e) +-- extract IO or an unboxed version of it, (ST, World -> (# Wold, a #)) +extractIO' :: E -> ([E],Bool,E) +extractIO' e = f e [] where + f (ELit LitCons { litName = c, litArgs = [x] }) rs | c == tc_IO = (reverse rs, True,x) + f (ELit LitCons { litName = c, litArgs = [_,x] }) rs | c == tc_ST = (reverse rs, True,x) + f (expandAlias -> Just t) rs = f t rs + f (fromPi -> (fromUnboxedTuple -> Just [s',x],[getType -> s''])) rs + | isState_ s' && isState_ s'' = (reverse rs, True,x) + f (EPi v e) rs = f e (getType v:rs) + f e rs = (reverse rs, False,e) +-- f (fromPi -> (getType -> s',[getType -> s''])) | isState_ s' && isState_ s'' = (True,tUnit) data ExtTypeInfo = ExtTypeVoid -- maps to 'void' hunk ./src/DataConstructors.hs 426 g e | Just e' <- followAlias dataTable e = f e' | otherwise = fail $ "lookupExtTypeInfo: " ++ show (oe,e) +expandAlias :: Monad m => E -> m E +expandAlias (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as) +expandAlias _ = fail "expandAlias: not alias" + followAlias :: Monad m => DataTable -> E -> m E followAlias _ (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as) followAlias _ _ = fail "followAlias: not alias" hunk ./src/DataConstructors.hs 888 (rt_float32, "float"), (rt_float64, "double"), (rt_float80, "long double"), - (rt_float128, "__float128") + (rt_float128, "__float128"), + (tc_Bang_, "wptr_t") ] -- which C types these convert to in FFI specifications for hunk ./src/DataConstructors.hs 938 (tc_CULong, "unsigned long"), (tc_CULLong, "unsigned long long"), - (tc_CWchar, "wchar_t"), (tc_CWint, "wint_t"), (tc_CTime, "time_t"), hunk ./src/DataConstructors.hs 944 (tc_CClock, "clock_t"), (tc_CSize, "size_t"), (tc_Unit, "void"), - (tc_State_, "void") + (tc_State_, "void"), + (tc_Bang_, "wptr_t") -- internal rts type ] hunk ./src/E/FromHs.hs 241 tvra = tVr vn sta Just (ExtTypeBoxed cna sta _) = lookupExtTypeInfo dataTable te -createFunc :: UniqueProducer m => DataTable -> [E] -> ([TVr] -> (E -> E,E)) -> m E +createFunc :: Monad t => DataTable -> [E] -> ([TVr] -> (E -> E,E)) -> Ce t E createFunc dataTable es ee = do xs <- flip mapM es $ \te -> do eti <- lookupExtTypeInfo dataTable te hunk ./src/E/FromHs.hs 366 } Identity funcs = T.mapM (return . EVar . toTVr assumps dataTable) sFuncNames Ce ans = do - nds <- mapM cDecl hsDecls + nds <- mapM cDecl' hsDecls return (map anninst $ concat nds) doNegate e = eAp (eAp (func_negate funcs) (getType e)) e anninst (a,b,c) hunk ./src/E/FromHs.hs 403 -- ccallHelper returns a function expression to perform the call, when given the arguments ccallHelper :: Monad m => ([ExtType] -> ExtType -> Bool -> [E] -> E -> E) -> E -> Ce m E ccallHelper myPrim ty = do - let (ts,rt) = argTypes' ty - (isIO,rt') = extractIO' rt + let --(ts,rt) = argTypes' ty + -- (isIO,rt') = extractIO' rt + (ts,isIO,rt') = extractIO' ty es <- newVars [ t | t <- ts, not (sortKindLike t) ] pt <- lookupExtTypeInfo dataTable rt' cts <- mapM (lookupExtTypeInfo dataTable) (filter (not . sortKindLike) ts) hunk ./src/E/FromHs.hs 444 let rttIO' = ltTuple' [tWorld__, rt'] case isIO of False -> cFun $ \rs -> (,) id $ (prim False [ EVar t | t <- rs ] rt') - True -> cFun $ \rs -> (,) (ELam tvrWorld) $ - eCaseTup' (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO') - [tvrWorld2,rtVar] - (eJustIO (EVar tvrWorld2) (EVar rtVar)) + True -> cFun $ \rs -> (,) (ELam tvrWorld) $ (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO') + --eCaseTup' (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO') + -- [tvrWorld2,rtVar] + -- (eJustIO (EVar tvrWorld2) (EVar rtVar)) hunk ./src/E/FromHs.hs 449 - cDecl :: Monad m => HsDecl -> Ce m [(Name,TVr,E)] + cDecl,cDecl' :: Monad m => HsDecl -> Ce m [(Name,TVr,E)] + cDecl' d = withSrcLoc (srcLoc d) $ cDecl d cDecl (HsForeignDecl sLoc (FfiSpec (Import cn req) _ Primitive) n _) = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name hunk ./src/E/FromHs.hs 498 cDecl (HsForeignDecl _ (FfiSpec (Import rcn _) _ DotNet) n _) = do (var,ty,lamt) <- convertValue (toName Name.Val n) - let (ts,rt) = argTypes' ty - (isIO,rt') = extractIO' rt + let --(ts,rt) = argTypes' ty + --(isIO,rt') = extractIO' rt + (ts,isIO,rt') = extractIO' ty es <- newVars [ t | t <- ts, not (sortKindLike t) ] pt <- lookupExtTypeInfo dataTable rt' [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__] hunk ./src/E/FromHs.hs 530 tn <- convertVar (toName Name.Val n) (var,ty,lamt) <- convertValue name - let (argTys,retTy') = argTypes' ty - (isIO,retTy) = extractIO' retTy' + let --(argTys,retTy') = argTypes' ty + --(isIO,retTy) = extractIO' retTy' + (argTys,isIO,retTy) = extractIO' ty --retCTy <- if retTy == tUnit -- then return unboxedTyUnit hunk ./src/E/Show.hs 159 tc_CClock, tc_Integer, tc_Int, tc_Int8, tc_Int16, tc_Int32, tc_Int64, tc_IntMax, tc_IntPtr, tc_Word, tc_Word8, tc_Word16, tc_Word32, tc_Word64, tc_WordMax, tc_WordPtr, tc_Addr_, tc_FunAddr_, - tc_Char_, dc_Boolzh, dc_Char, dc_Int, dc_Integer, dc_Word ] + tc_Char_, dc_Boolzh, dc_Char, dc_Int, dc_Integer, dc_Word, + tc_ST, tc_Bang_] shortName = Map.fromList [ (x, toUnqualified x) | x <- short_names] hunk ./src/Grin/FromE.hs 429 return $ BaseOp PokeVal [(Index r' o'),v'] -- rts f "toBang_" (args -> [x]) = do - return $ gEval x + return $ if getType x == tyDNode then Return [x] else gEval x f "fromBang_" [x] = do hunk ./src/Grin/FromE.hs 431 - return (BaseOp Demote $ args [x]) + return $ Return (args [x]) -- (BaseOp Demote $ args [x]) f "mallocHeapWords" [w,_] = do let [c] = args [w] v <- newPrimVar (TyPtr (TyPrim Op.bits_ptr)) hunk ./src/Grin/FromE.hs 571 -- | cc evaluates something in lazy context, returning a pointer to a node which when evaluated will produce the strict result. -- it is an invarient that evaling (cc e) produces the same value as (ce e) cc (EPrim don [e,_] _) | don == p_dependingOn = cc e + cc (EPrim (APrim (PrimPrim "fromBang_") _) (args -> [e]) _) = return $ if getType e == tyDNode then demote e else Return [e] -- $ demote e +-- e <- ce e +-- return $ e :>>= [v] :-> demote v cc e | Just _ <- literal e = error "unboxed literal in lazy context" cc e | Just z <- constant e = return (Return $ keepIts [z]) cc e | Just [z] <- con e = return $ bool (isLifted e) istore dstore z -- BaseOp (StoreNode (not $ isLifted e)) [z] -- if isLifted e then Store z else Return [z] hunk ./src/Grin/Main.hs 94 (cc,args) <- fetchCompilerFlags tdir <- getTempDir ds <- catch (getDirectoryContents (tdir FP. "cbits")) (\_ -> return []) - let extraCFiles = ["-I" ++ tdir ++ "/cbits" ] ++ [ tdir FP. "cbits" FP. fn | fn@(reverse -> 'c':'.':_) <- ds ] + let extraCFiles = ["-I" ++ tdir ++ "/cbits" ] ++ [ tdir FP. "cbits" FP. fn | fn@(reverse -> 'c':'.':_) <- ds ] let comm = shellQuote $ [cc] ++ ["-o", fn, cf] ++ args ++ (map ("-l" ++) rls) ++ extraCFiles globalvar n c = LBS.fromString $ "char " ++ n ++ "[] = \"" ++ c ++ "\";" putProgressLn ("Writing " ++ show cf) hunk ./src/data/names.txt 12 List Jhc.Prim.Prim.[] Char Jhc.Type.Basic.Char IO Jhc.Prim.IO.IO +ST Jhc.Prim.IO.ST ACIO Jhc.Prim.IO.ACIO State_ Jhc.Prim.IO.State_ RealWorld Jhc.Prim.IO.RealWorld [clean up handling of raw files, keep source file separate when compiling. include useful header files when compiling. John Meacham **20120207115605 Ignore-this: 36df85f4ad0b25b1cafc02ecb98657cc ] hunk ./Makefile.am 102 UTILS = utils/op_process.prl utils/opt_sets.prl utils/gen_props.prl utils/op_names.prl utils/op_raw.prl -RAWFILES = src/data/ViaGhc.hs ChangeLog \ - src/data/shortchange.txt src/data/prelude.m4 src/data/targets.ini +RAWFILES = src/data/ViaGhc.hs ChangeLog src/data/shortchange.txt src/data/prelude.m4 \ + src/data/targets.ini rts/rts_constants.h rts/stableptr.c rts/queue.h src/data/HsFFI.h \ + rts/wsize.h rts/bitarray.h hunk ./Makefile.am 106 -RTSFILES = src/data/HsFFI.h rts/wsize.h rts/jhc_rts_header.h rts/jhc_jgc.h \ - rts/debug.c rts/jhc_rts_alloc.c rts/jhc_rts.c rts/profile.c rts/jhc_rts2.c rts/bitarray.h \ - rts/slub.c rts/jhc_jgc.c rts/lib_cbits.c +RTSFILES = rts/jhc_rts_header.h rts/jhc_jgc.h \ + rts/debug.c rts/jhc_rts_alloc.c rts/jhc_rts.c rts/profile.c rts/jhc_rts2.c \ + rts/slub.c rts/jhc_jgc.c rts/lib_cbits.c DRIFTFILES = drift_processed/C/FFI.hs drift_processed/C/FromGrin2.hs drift_processed/Cmm/Op.hs drift_processed/C/Prims.hs drift_processed/DataConstructors.hs \ drift_processed/DerivingDrift/StandardRules.hs drift_processed/E/CPR.hs drift_processed/E/Demand.hs drift_processed/E/LambdaLift.hs \ hunk ./rts/jhc_rts_header.h 28 #include #endif +#include "HsFFI.h" +#include "rts/wsize.h" +#include "rts/bitarray.h" +#include "sys/queue.h" + // #define our options #define _JHC_GC_NONE 0 addfile ./rts/queue.h hunk ./rts/queue.h 1 +/* + * Copyright (c) 1991, 1993 + * The Regents of the University of California. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + * + * @(#)queue.h 8.5 (Berkeley) 8/20/94 + */ + +#ifndef _SYS_QUEUE_H_ +#define _SYS_QUEUE_H_ + +/* + * This file defines five types of data structures: singly-linked lists, + * lists, simple queues, tail queues, and circular queues. + * + * A singly-linked list is headed by a single forward pointer. The + * elements are singly linked for minimum space and pointer manipulation + * overhead at the expense of O(n) removal for arbitrary elements. New + * elements can be added to the list after an existing element or at the + * head of the list. Elements being removed from the head of the list + * should use the explicit macro for this purpose for optimum + * efficiency. A singly-linked list may only be traversed in the forward + * direction. Singly-linked lists are ideal for applications with large + * datasets and few or no removals or for implementing a LIFO queue. + * + * A list is headed by a single forward pointer (or an array of forward + * pointers for a hash table header). The elements are doubly linked + * so that an arbitrary element can be removed without a need to + * traverse the list. New elements can be added to the list before + * or after an existing element or at the head of the list. A list + * may only be traversed in the forward direction. + * + * A simple queue is headed by a pair of pointers, one the head of the + * list and the other to the tail of the list. The elements are singly + * linked to save space, so elements can only be removed from the + * head of the list. New elements can be added to the list after + * an existing element, at the head of the list, or at the end of the + * list. A simple queue may only be traversed in the forward direction. + * + * A tail queue is headed by a pair of pointers, one to the head of the + * list and the other to the tail of the list. The elements are doubly + * linked so that an arbitrary element can be removed without a need to + * traverse the list. New elements can be added to the list before or + * after an existing element, at the head of the list, or at the end of + * the list. A tail queue may be traversed in either direction. + * + * A circle queue is headed by a pair of pointers, one to the head of the + * list and the other to the tail of the list. The elements are doubly + * linked so that an arbitrary element can be removed without a need to + * traverse the list. New elements can be added to the list before or after + * an existing element, at the head of the list, or at the end of the list. + * A circle queue may be traversed in either direction, but has a more + * complex end of list detection. + * + * For details on the use of these macros, see the queue(3) manual page. + */ + +/* + * List definitions. + */ +#define LIST_HEAD(name, type) \ +struct name { \ + struct type *lh_first; /* first element */ \ +} + +#define LIST_HEAD_INITIALIZER(head) \ + { NULL } + +#define LIST_ENTRY(type) \ +struct { \ + struct type *le_next; /* next element */ \ + struct type **le_prev; /* address of previous next element */ \ +} + +/* + * List functions. + */ +#define LIST_INIT(head) do { \ + (head)->lh_first = NULL; \ +} while (/*CONSTCOND*/0) + +#define LIST_INSERT_AFTER(listelm, elm, field) do { \ + if (((elm)->field.le_next = (listelm)->field.le_next) != NULL) \ + (listelm)->field.le_next->field.le_prev = \ + &(elm)->field.le_next; \ + (listelm)->field.le_next = (elm); \ + (elm)->field.le_prev = &(listelm)->field.le_next; \ +} while (/*CONSTCOND*/0) + +#define LIST_INSERT_BEFORE(listelm, elm, field) do { \ + (elm)->field.le_prev = (listelm)->field.le_prev; \ + (elm)->field.le_next = (listelm); \ + *(listelm)->field.le_prev = (elm); \ + (listelm)->field.le_prev = &(elm)->field.le_next; \ +} while (/*CONSTCOND*/0) + +#define LIST_INSERT_HEAD(head, elm, field) do { \ + if (((elm)->field.le_next = (head)->lh_first) != NULL) \ + (head)->lh_first->field.le_prev = &(elm)->field.le_next;\ + (head)->lh_first = (elm); \ + (elm)->field.le_prev = &(head)->lh_first; \ +} while (/*CONSTCOND*/0) + +#define LIST_REMOVE(elm, field) do { \ + if ((elm)->field.le_next != NULL) \ + (elm)->field.le_next->field.le_prev = \ + (elm)->field.le_prev; \ + *(elm)->field.le_prev = (elm)->field.le_next; \ +} while (/*CONSTCOND*/0) + +#define LIST_FOREACH(var, head, field) \ + for ((var) = ((head)->lh_first); \ + (var); \ + (var) = ((var)->field.le_next)) + +/* + * List access methods. + */ +#define LIST_EMPTY(head) ((head)->lh_first == NULL) +#define LIST_FIRST(head) ((head)->lh_first) +#define LIST_NEXT(elm, field) ((elm)->field.le_next) + + +/* + * Singly-linked List definitions. + */ +#define SLIST_HEAD(name, type) \ +struct name { \ + struct type *slh_first; /* first element */ \ +} + +#define SLIST_HEAD_INITIALIZER(head) \ + { NULL } + +#define SLIST_ENTRY(type) \ +struct { \ + struct type *sle_next; /* next element */ \ +} + +/* + * Singly-linked List functions. + */ +#define SLIST_INIT(head) do { \ + (head)->slh_first = NULL; \ +} while (/*CONSTCOND*/0) + +#define SLIST_INSERT_AFTER(slistelm, elm, field) do { \ + (elm)->field.sle_next = (slistelm)->field.sle_next; \ + (slistelm)->field.sle_next = (elm); \ +} while (/*CONSTCOND*/0) + +#define SLIST_INSERT_HEAD(head, elm, field) do { \ + (elm)->field.sle_next = (head)->slh_first; \ + (head)->slh_first = (elm); \ +} while (/*CONSTCOND*/0) + +#define SLIST_REMOVE_HEAD(head, field) do { \ + (head)->slh_first = (head)->slh_first->field.sle_next; \ +} while (/*CONSTCOND*/0) + +#define SLIST_REMOVE(head, elm, type, field) do { \ + if ((head)->slh_first == (elm)) { \ + SLIST_REMOVE_HEAD((head), field); \ + } \ + else { \ + struct type *curelm = (head)->slh_first; \ + while(curelm->field.sle_next != (elm)) \ + curelm = curelm->field.sle_next; \ + curelm->field.sle_next = \ + curelm->field.sle_next->field.sle_next; \ + } \ +} while (/*CONSTCOND*/0) + +#define SLIST_FOREACH(var, head, field) \ + for((var) = (head)->slh_first; (var); (var) = (var)->field.sle_next) + +/* + * Singly-linked List access methods. + */ +#define SLIST_EMPTY(head) ((head)->slh_first == NULL) +#define SLIST_FIRST(head) ((head)->slh_first) +#define SLIST_NEXT(elm, field) ((elm)->field.sle_next) + + +/* + * Singly-linked Tail queue declarations. + */ +#define STAILQ_HEAD(name, type) \ +struct name { \ + struct type *stqh_first; /* first element */ \ + struct type **stqh_last; /* addr of last next element */ \ +} + +#define STAILQ_HEAD_INITIALIZER(head) \ + { NULL, &(head).stqh_first } + +#define STAILQ_ENTRY(type) \ +struct { \ + struct type *stqe_next; /* next element */ \ +} + +/* + * Singly-linked Tail queue functions. + */ +#define STAILQ_INIT(head) do { \ + (head)->stqh_first = NULL; \ + (head)->stqh_last = &(head)->stqh_first; \ +} while (/*CONSTCOND*/0) + +#define STAILQ_INSERT_HEAD(head, elm, field) do { \ + if (((elm)->field.stqe_next = (head)->stqh_first) == NULL) \ + (head)->stqh_last = &(elm)->field.stqe_next; \ + (head)->stqh_first = (elm); \ +} while (/*CONSTCOND*/0) + +#define STAILQ_INSERT_TAIL(head, elm, field) do { \ + (elm)->field.stqe_next = NULL; \ + *(head)->stqh_last = (elm); \ + (head)->stqh_last = &(elm)->field.stqe_next; \ +} while (/*CONSTCOND*/0) + +#define STAILQ_INSERT_AFTER(head, listelm, elm, field) do { \ + if (((elm)->field.stqe_next = (listelm)->field.stqe_next) == NULL)\ + (head)->stqh_last = &(elm)->field.stqe_next; \ + (listelm)->field.stqe_next = (elm); \ +} while (/*CONSTCOND*/0) + +#define STAILQ_REMOVE_HEAD(head, field) do { \ + if (((head)->stqh_first = (head)->stqh_first->field.stqe_next) == NULL) \ + (head)->stqh_last = &(head)->stqh_first; \ +} while (/*CONSTCOND*/0) + +#define STAILQ_REMOVE(head, elm, type, field) do { \ + if ((head)->stqh_first == (elm)) { \ + STAILQ_REMOVE_HEAD((head), field); \ + } else { \ + struct type *curelm = (head)->stqh_first; \ + while (curelm->field.stqe_next != (elm)) \ + curelm = curelm->field.stqe_next; \ + if ((curelm->field.stqe_next = \ + curelm->field.stqe_next->field.stqe_next) == NULL) \ + (head)->stqh_last = &(curelm)->field.stqe_next; \ + } \ +} while (/*CONSTCOND*/0) + +#define STAILQ_FOREACH(var, head, field) \ + for ((var) = ((head)->stqh_first); \ + (var); \ + (var) = ((var)->field.stqe_next)) + +#define STAILQ_CONCAT(head1, head2) do { \ + if (!STAILQ_EMPTY((head2))) { \ + *(head1)->stqh_last = (head2)->stqh_first; \ + (head1)->stqh_last = (head2)->stqh_last; \ + STAILQ_INIT((head2)); \ + } \ +} while (/*CONSTCOND*/0) + +/* + * Singly-linked Tail queue access methods. + */ +#define STAILQ_EMPTY(head) ((head)->stqh_first == NULL) +#define STAILQ_FIRST(head) ((head)->stqh_first) +#define STAILQ_NEXT(elm, field) ((elm)->field.stqe_next) + + +/* + * Simple queue definitions. + */ +#define SIMPLEQ_HEAD(name, type) \ +struct name { \ + struct type *sqh_first; /* first element */ \ + struct type **sqh_last; /* addr of last next element */ \ +} + +#define SIMPLEQ_HEAD_INITIALIZER(head) \ + { NULL, &(head).sqh_first } + +#define SIMPLEQ_ENTRY(type) \ +struct { \ + struct type *sqe_next; /* next element */ \ +} + +/* + * Simple queue functions. + */ +#define SIMPLEQ_INIT(head) do { \ + (head)->sqh_first = NULL; \ + (head)->sqh_last = &(head)->sqh_first; \ +} while (/*CONSTCOND*/0) + +#define SIMPLEQ_INSERT_HEAD(head, elm, field) do { \ + if (((elm)->field.sqe_next = (head)->sqh_first) == NULL) \ + (head)->sqh_last = &(elm)->field.sqe_next; \ + (head)->sqh_first = (elm); \ +} while (/*CONSTCOND*/0) + +#define SIMPLEQ_INSERT_TAIL(head, elm, field) do { \ + (elm)->field.sqe_next = NULL; \ + *(head)->sqh_last = (elm); \ + (head)->sqh_last = &(elm)->field.sqe_next; \ +} while (/*CONSTCOND*/0) + +#define SIMPLEQ_INSERT_AFTER(head, listelm, elm, field) do { \ + if (((elm)->field.sqe_next = (listelm)->field.sqe_next) == NULL)\ + (head)->sqh_last = &(elm)->field.sqe_next; \ + (listelm)->field.sqe_next = (elm); \ +} while (/*CONSTCOND*/0) + +#define SIMPLEQ_REMOVE_HEAD(head, field) do { \ + if (((head)->sqh_first = (head)->sqh_first->field.sqe_next) == NULL) \ + (head)->sqh_last = &(head)->sqh_first; \ +} while (/*CONSTCOND*/0) + +#define SIMPLEQ_REMOVE(head, elm, type, field) do { \ + if ((head)->sqh_first == (elm)) { \ + SIMPLEQ_REMOVE_HEAD((head), field); \ + } else { \ + struct type *curelm = (head)->sqh_first; \ + while (curelm->field.sqe_next != (elm)) \ + curelm = curelm->field.sqe_next; \ + if ((curelm->field.sqe_next = \ + curelm->field.sqe_next->field.sqe_next) == NULL) \ + (head)->sqh_last = &(curelm)->field.sqe_next; \ + } \ +} while (/*CONSTCOND*/0) + +#define SIMPLEQ_FOREACH(var, head, field) \ + for ((var) = ((head)->sqh_first); \ + (var); \ + (var) = ((var)->field.sqe_next)) + +/* + * Simple queue access methods. + */ +#define SIMPLEQ_EMPTY(head) ((head)->sqh_first == NULL) +#define SIMPLEQ_FIRST(head) ((head)->sqh_first) +#define SIMPLEQ_NEXT(elm, field) ((elm)->field.sqe_next) + + +/* + * Tail queue definitions. + */ +#define _TAILQ_HEAD(name, type, qual) \ +struct name { \ + qual type *tqh_first; /* first element */ \ + qual type *qual *tqh_last; /* addr of last next element */ \ +} +#define TAILQ_HEAD(name, type) _TAILQ_HEAD(name, struct type,) + +#define TAILQ_HEAD_INITIALIZER(head) \ + { NULL, &(head).tqh_first } + +#define _TAILQ_ENTRY(type, qual) \ +struct { \ + qual type *tqe_next; /* next element */ \ + qual type *qual *tqe_prev; /* address of previous next element */\ +} +#define TAILQ_ENTRY(type) _TAILQ_ENTRY(struct type,) + +/* + * Tail queue functions. + */ +#define TAILQ_INIT(head) do { \ + (head)->tqh_first = NULL; \ + (head)->tqh_last = &(head)->tqh_first; \ +} while (/*CONSTCOND*/0) + +#define TAILQ_INSERT_HEAD(head, elm, field) do { \ + if (((elm)->field.tqe_next = (head)->tqh_first) != NULL) \ + (head)->tqh_first->field.tqe_prev = \ + &(elm)->field.tqe_next; \ + else \ + (head)->tqh_last = &(elm)->field.tqe_next; \ + (head)->tqh_first = (elm); \ + (elm)->field.tqe_prev = &(head)->tqh_first; \ +} while (/*CONSTCOND*/0) + +#define TAILQ_INSERT_TAIL(head, elm, field) do { \ + (elm)->field.tqe_next = NULL; \ + (elm)->field.tqe_prev = (head)->tqh_last; \ + *(head)->tqh_last = (elm); \ + (head)->tqh_last = &(elm)->field.tqe_next; \ +} while (/*CONSTCOND*/0) + +#define TAILQ_INSERT_AFTER(head, listelm, elm, field) do { \ + if (((elm)->field.tqe_next = (listelm)->field.tqe_next) != NULL)\ + (elm)->field.tqe_next->field.tqe_prev = \ + &(elm)->field.tqe_next; \ + else \ + (head)->tqh_last = &(elm)->field.tqe_next; \ + (listelm)->field.tqe_next = (elm); \ + (elm)->field.tqe_prev = &(listelm)->field.tqe_next; \ +} while (/*CONSTCOND*/0) + +#define TAILQ_INSERT_BEFORE(listelm, elm, field) do { \ + (elm)->field.tqe_prev = (listelm)->field.tqe_prev; \ + (elm)->field.tqe_next = (listelm); \ + *(listelm)->field.tqe_prev = (elm); \ + (listelm)->field.tqe_prev = &(elm)->field.tqe_next; \ +} while (/*CONSTCOND*/0) + +#define TAILQ_REMOVE(head, elm, field) do { \ + if (((elm)->field.tqe_next) != NULL) \ + (elm)->field.tqe_next->field.tqe_prev = \ + (elm)->field.tqe_prev; \ + else \ + (head)->tqh_last = (elm)->field.tqe_prev; \ + *(elm)->field.tqe_prev = (elm)->field.tqe_next; \ +} while (/*CONSTCOND*/0) + +#define TAILQ_FOREACH(var, head, field) \ + for ((var) = ((head)->tqh_first); \ + (var); \ + (var) = ((var)->field.tqe_next)) + +#define TAILQ_FOREACH_REVERSE(var, head, headname, field) \ + for ((var) = (*(((struct headname *)((head)->tqh_last))->tqh_last)); \ + (var); \ + (var) = (*(((struct headname *)((var)->field.tqe_prev))->tqh_last))) + +#define TAILQ_CONCAT(head1, head2, field) do { \ + if (!TAILQ_EMPTY(head2)) { \ + *(head1)->tqh_last = (head2)->tqh_first; \ + (head2)->tqh_first->field.tqe_prev = (head1)->tqh_last; \ + (head1)->tqh_last = (head2)->tqh_last; \ + TAILQ_INIT((head2)); \ + } \ +} while (/*CONSTCOND*/0) + +/* + * Tail queue access methods. + */ +#define TAILQ_EMPTY(head) ((head)->tqh_first == NULL) +#define TAILQ_FIRST(head) ((head)->tqh_first) +#define TAILQ_NEXT(elm, field) ((elm)->field.tqe_next) + +#define TAILQ_LAST(head, headname) \ + (*(((struct headname *)((head)->tqh_last))->tqh_last)) +#define TAILQ_PREV(elm, headname, field) \ + (*(((struct headname *)((elm)->field.tqe_prev))->tqh_last)) + + +/* + * Circular queue definitions. + */ +#define CIRCLEQ_HEAD(name, type) \ +struct name { \ + struct type *cqh_first; /* first element */ \ + struct type *cqh_last; /* last element */ \ +} + +#define CIRCLEQ_HEAD_INITIALIZER(head) \ + { (void *)&head, (void *)&head } + +#define CIRCLEQ_ENTRY(type) \ +struct { \ + struct type *cqe_next; /* next element */ \ + struct type *cqe_prev; /* previous element */ \ +} + +/* + * Circular queue functions. + */ +#define CIRCLEQ_INIT(head) do { \ + (head)->cqh_first = (void *)(head); \ + (head)->cqh_last = (void *)(head); \ +} while (/*CONSTCOND*/0) + +#define CIRCLEQ_INSERT_AFTER(head, listelm, elm, field) do { \ + (elm)->field.cqe_next = (listelm)->field.cqe_next; \ + (elm)->field.cqe_prev = (listelm); \ + if ((listelm)->field.cqe_next == (void *)(head)) \ + (head)->cqh_last = (elm); \ + else \ + (listelm)->field.cqe_next->field.cqe_prev = (elm); \ + (listelm)->field.cqe_next = (elm); \ +} while (/*CONSTCOND*/0) + +#define CIRCLEQ_INSERT_BEFORE(head, listelm, elm, field) do { \ + (elm)->field.cqe_next = (listelm); \ + (elm)->field.cqe_prev = (listelm)->field.cqe_prev; \ + if ((listelm)->field.cqe_prev == (void *)(head)) \ + (head)->cqh_first = (elm); \ + else \ + (listelm)->field.cqe_prev->field.cqe_next = (elm); \ + (listelm)->field.cqe_prev = (elm); \ +} while (/*CONSTCOND*/0) + +#define CIRCLEQ_INSERT_HEAD(head, elm, field) do { \ + (elm)->field.cqe_next = (head)->cqh_first; \ + (elm)->field.cqe_prev = (void *)(head); \ + if ((head)->cqh_last == (void *)(head)) \ + (head)->cqh_last = (elm); \ + else \ + (head)->cqh_first->field.cqe_prev = (elm); \ + (head)->cqh_first = (elm); \ +} while (/*CONSTCOND*/0) + +#define CIRCLEQ_INSERT_TAIL(head, elm, field) do { \ + (elm)->field.cqe_next = (void *)(head); \ + (elm)->field.cqe_prev = (head)->cqh_last; \ + if ((head)->cqh_first == (void *)(head)) \ + (head)->cqh_first = (elm); \ + else \ + (head)->cqh_last->field.cqe_next = (elm); \ + (head)->cqh_last = (elm); \ +} while (/*CONSTCOND*/0) + +#define CIRCLEQ_REMOVE(head, elm, field) do { \ + if ((elm)->field.cqe_next == (void *)(head)) \ + (head)->cqh_last = (elm)->field.cqe_prev; \ + else \ + (elm)->field.cqe_next->field.cqe_prev = \ + (elm)->field.cqe_prev; \ + if ((elm)->field.cqe_prev == (void *)(head)) \ + (head)->cqh_first = (elm)->field.cqe_next; \ + else \ + (elm)->field.cqe_prev->field.cqe_next = \ + (elm)->field.cqe_next; \ +} while (/*CONSTCOND*/0) + +#define CIRCLEQ_FOREACH(var, head, field) \ + for ((var) = ((head)->cqh_first); \ + (var) != (const void *)(head); \ + (var) = ((var)->field.cqe_next)) + +#define CIRCLEQ_FOREACH_REVERSE(var, head, field) \ + for ((var) = ((head)->cqh_last); \ + (var) != (const void *)(head); \ + (var) = ((var)->field.cqe_prev)) + +/* + * Circular queue access methods. + */ +#define CIRCLEQ_EMPTY(head) ((head)->cqh_first == (void *)(head)) +#define CIRCLEQ_FIRST(head) ((head)->cqh_first) +#define CIRCLEQ_LAST(head) ((head)->cqh_last) +#define CIRCLEQ_NEXT(elm, field) ((elm)->field.cqe_next) +#define CIRCLEQ_PREV(elm, field) ((elm)->field.cqe_prev) + +#define CIRCLEQ_LOOP_NEXT(head, elm, field) \ + (((elm)->field.cqe_next == (void *)(head)) \ + ? ((head)->cqh_first) \ + : (elm->field.cqe_next)) +#define CIRCLEQ_LOOP_PREV(head, elm, field) \ + (((elm)->field.cqe_prev == (void *)(head)) \ + ? ((head)->cqh_last) \ + : (elm->field.cqe_prev)) + +#endif /* sys/queue.h */ hunk ./rts/slub.c 2 #if _JHC_GC == _JHC_GC_JGC -/* - * Singly-linked List definitions. - */ -#define SLIST_HEAD(name, type) \ -struct name { \ - struct type *slh_first; /* first element */ \ -} -#define SLIST_ENTRY(type) \ -struct { \ - struct type *sle_next; /* next element */ \ -} -#define SLIST_INIT(head) do { \ - (head)->slh_first = NULL; \ -} while (/*CONSTCOND*/0) -#define SLIST_INSERT_HEAD(head, elm, field) do { \ - (elm)->field.sle_next = (head)->slh_first; \ - (head)->slh_first = (elm); \ -} while (/*CONSTCOND*/0) -#define SLIST_REMOVE_HEAD(head, field) do { \ - (head)->slh_first = (head)->slh_first->field.sle_next; \ -} while (/*CONSTCOND*/0) -#define SLIST_FIRST(head) ((head)->slh_first) -#define SLIST_NEXT(elm, field) ((elm)->field.sle_next) -#define SLIST_FOREACH(var, head, field) \ - for((var) = (head)->slh_first; (var); (var) = (var)->field.sle_next) #define BLOCK_SIZE (1UL << 12) #define MEGABLOCK_SIZE (1UL << 20) addfile ./rts/stableptr.c hunk ./rts/stableptr.c 1 +struct StablePtr { + LIST_ENTRY(StablePtr) link; + sptr_t contents; +}; + +LIST_HEAD(, StablePtr) root_StablePtrs = LIST_HEAD_INITIALIZER(); + +wptr_t c_newStablePtr(sptr_t c) { + struct StablePtr* sp = malloc(sizeof(struct StablePtr)); + sp->contents = c; + LIST_INSERT_HEAD(&root_StablePtrs, sp, link); + assert(GET_PTYPE(sp) == 0); + return (wptr_t)TO_SPTR(P_VALUE,(wptr_t)sp); +} + +void c_freeStablePtr(wptr_t wp) { + struct StablePtr *sp = FROM_SPTR((HsPtr)wp); + LIST_REMOVE(sp, link); + free(sp); +} + +sptr_t c_derefStablePtr(wptr_t wp) { + struct StablePtr *sp = FROM_SPTR((HsPtr)wp); + return sp->contents; +} hunk ./src/C/FromGrin2.hs 10 import Data.List import Data.Maybe import Data.Monoid +import System.FilePath import Text.PrettyPrint.HughesPJ(nest,($$),fsep) hunk ./src/C/FromGrin2.hs 12 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.UTF8 as BS import qualified Data.Map as Map import qualified Data.Set as Set import qualified Text.PrettyPrint.HughesPJ as P hunk ./src/C/FromGrin2.hs 39 import Util.SetLike import Util.UniqueMonad import qualified Cmm.Op as Op -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.UTF8 as BS import qualified FlagOpts as FO --------------- hunk ./src/C/FromGrin2.hs 136 ans = vcat [ vcat includes, vcat jgcs, + vcat cincludes, text "", enum_tag_t, header, hunk ./src/C/FromGrin2.hs 150 jgcs | fopts FO.Jgc = [ text "static struct s_cache *" <> tshow (nodeCacheName m) <> char ';' | (m,_) <- Set.toList wAllocs] | otherwise = empty nh_stuff = text "static const void * const nh_stuff[] = {" $$ fsep (punctuate (char ',') (cafnames ++ constnames ++ [text "NULL"])) $$ text "};" - includes = map include (snub $ reqIncludes req) + includes = map include (filter ((".h" ==) . takeExtension) $ snub $ reqIncludes req) + cincludes = map include (filter ((".c" ==) . takeExtension) $ snub $ reqIncludes req) include fn = text "#include <" <> text fn <> text ">" (header,body) = generateC (function (name "jhc_hs_init") voidType [] [] icaches:Map.elems fm) (Map.elems sm) icaches :: Statement hunk ./src/Grin/Main.hs 6 import Control.Monad import Data.Monoid(mappend) import System.Directory +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.UTF8 as LBS import qualified Data.Map as Map hunk ./src/Grin/Main.hs 26 import Grin.StorageAnalysis import Ho.ReadSource import Options +import RawFiles import Support.TempDir import Support.Transform import Util.Gen hunk ./src/Grin/Main.hs 94 | otherwise -> fileInTempDir ("main_code.c") (\_ -> return ()) (argstring,sversion) <- getArgString (cc,args) <- fetchCompilerFlags + forM_ [("rts/rts_constants.h",rts_constants_h),("rts/stableptr.c",stableptr_c), + ("sys/queue.h",queue_h),("HsFFI.h",hsffi_h),("rts/wsize.h",wsize_h), + ("rts/bitarray.h",bitarray_h)] $ \ (fn,bs) -> do + fileInTempDir fn $ flip BS.writeFile bs + tdir <- getTempDir ds <- catch (getDirectoryContents (tdir FP. "cbits")) (\_ -> return []) hunk ./src/Grin/Main.hs 101 - let extraCFiles = ["-I" ++ tdir ++ "/cbits" ] ++ [ tdir FP. "cbits" FP. fn | fn@(reverse -> 'c':'.':_) <- ds ] + let extraCFiles = ["-I" ++ tdir ++ "/cbits", "-I" ++ tdir ] ++ [ tdir FP. "cbits" FP. fn | fn@(reverse -> 'c':'.':_) <- ds ] let comm = shellQuote $ [cc] ++ ["-o", fn, cf] ++ args ++ (map ("-l" ++) rls) ++ extraCFiles globalvar n c = LBS.fromString $ "char " ++ n ++ "[] = \"" ++ c ++ "\";" putProgressLn ("Writing " ++ show cf) [fixes for distribution. John Meacham **20120208015220 Ignore-this: 5844114c6728be83bd526d50333d0204 ] hunk ./Makefile.am 64 JHC_LIBS = jhc-1.0.hl base-1.0.hl haskell98-1.0.hl applicative-1.0.hl flat-foreign-1.0.hl jhc-prim-1.0.hl EXTRA_DIST = src/data rts utils docs src/FrontEnd/HsParser.y $(BUILT_SOURCES) \ - lib/jhc lib/base lib/haskell98 lib/flat-foreign $(JHC_LIBS) $(JHC_EXT_LIBS) \ + lib/jhc lib/jhc-prim lib/base lib/haskell98 lib/flat-foreign $(JHC_LIBS) $(JHC_EXT_LIBS) \ src/StringTable/StringTable_cbits.c src/StringTable/StringTable_cbits.h src/cbits/md5sum.c jhc.1 \ src/StringTable/Atom.hsc jhc.spec src/cbits/lookup3.c \ manual.html lib/applicative examples/HelloWorld.hs examples/Calendar.hs \ hunk ./Makefile.am 68 - src/FlagOpts.flags src/FlagDump.flags lib/ext + examples/Primes.hs src/FlagOpts.flags src/FlagDump.flags lib/ext + +dist-hook: $(BUILT_SOURCES) + if test -f _darcs; then \ + rm -f $(srcdir)/ChangeLog $(srcdir)/src/data/shortchange.txt; \ + $(MAKE) ChangeLog src/data/shortchange.txt src/RawFiles.hs; \ + cp -f $(srcdir)/ChangeLog $(destdir)/ChangeLog; \ + cp -f $(srcdir)/src/data/shortchange.txt $(destdir)/src/data/shortchange.txt; \ + cp -f $(srcdir)/src/RawFiles.hs $(destdir)/src/RawFiles.hs; \ + fi # we recreate the manual and man page here just to ensure they are up to date hunk ./Makefile.am 80 -dist-hook: man manual - cp $(srcdir)/manual.html $(distdir)/manual.html - cp $(srcdir)/jhc.1 $(distdir)/jhc.1 - find $(distdir) \( -name _darcs -o -name \*.ho \) -print | xargs rm -rf -- +#dist-hook: man manual $(BUILT_SOURCES) +# cp $(srcdir)/manual.html $(distdir)/manual.html +# cp $(srcdir)/jhc.1 $(distdir)/jhc.1 + + #find $(distdir) \( -name _darcs -o -name \*.ho \) -print | xargs rm -rf -- all-local: $(JHC_LIBS) hunk ./Makefile.am 112 UTILS = utils/op_process.prl utils/opt_sets.prl utils/gen_props.prl utils/op_names.prl utils/op_raw.prl -RAWFILES = src/data/ViaGhc.hs ChangeLog src/data/shortchange.txt src/data/prelude.m4 \ +RAWFILES = src/data/ViaGhc.hs src/data/prelude.m4 \ src/data/targets.ini rts/rts_constants.h rts/stableptr.c rts/queue.h src/data/HsFFI.h \ hunk ./Makefile.am 114 - rts/wsize.h rts/bitarray.h + rts/wsize.h rts/bitarray.h ChangeLog src/data/shortchange.txt RTSFILES = rts/jhc_rts_header.h rts/jhc_jgc.h \ rts/debug.c rts/jhc_rts_alloc.c rts/jhc_rts.c rts/profile.c rts/jhc_rts2.c \ hunk ./Makefile.am 157 mkdir -p `echo $@ | sed -e 's@/[^/]*$$@@'` $(HSC2HS) $(MY_CINCLUDES) -o $@ $< -%.hs: %.flags utils/opt_sets.prl +%.hs: %.flags utils/opt_sets.prl perl $(srcdir)/utils/opt_sets.prl -n $< $< > $@ hunk ./Makefile.am 160 -%.mkd: %.flags utils/opt_sets.prl +%.mkd: %.flags utils/opt_sets.prl perl $(srcdir)/utils/opt_sets.prl -f f -m -n $< $< > $@ src/Info/Properties.hs: src/data/props.txt utils/gen_props.prl hunk ./Makefile.am 169 src/Name/Prim.hs: utils/op_names.prl src/data/names.txt perl $< > $@ || rm -f $@ -src/RawFiles.hs: utils/op_raw.prl $(RAWFILES) - perl $< $(basename $@) $(RAWFILES) > $@ +src/RawFiles.hs: $(RAWFILES) + perl $(srcdir)/utils/op_raw.prl $(basename $@) $^ > $@ hunk ./Makefile.am 172 -src/RtsFiles.hs: utils/op_raw.prl $(RTSFILES) - perl $< -c $(basename $@) $(RTSFILES) > $@ +src/RtsFiles.hs: $(RTSFILES) + perl $(srcdir)/utils/op_raw.prl -c $(basename $@) $^ > $@ src/FrontEnd/HsParser.hs: src/FrontEnd/HsParser.y happy -a -g -c $< -o $@ hunk ./Makefile.am 180 .SECONDARY: _darcs/hashed_inventory src/data/shortchange.txt -ChangeLog: _darcs/hashed_inventory +ChangeLog: darcs changes --from-tag . > $@ src/data/shortchange.txt: ChangeLog hunk ./Makefile.am 197 gzip -f -- $(BINDISTDIR).tar rm -rf -- $(BINDISTDIR) -.INTERMEDIATE: deps.txt jhc_man.mkd options.mkd +.INTERMEDIATE: deps.txt jhc_man.mkd options.mkd .DELETE_ON_ERROR: deps.txt depend.make ChangeLog data/shortchange.txt manual.mkd jhc_man.mkd options.mkd deps.txt: hunk ./Makefile.am 230 MAINTAINERCLEANFILES= $(BUILT_SOURCES) $(DRIFTFILES) -CLEANFILES= $(JHC_LIBS) $(JHC_EXT_LIBS) +CLEANFILES= $(JHC_LIBS) $(JHC_EXT_LIBS) HelloWorld Primes src/StringTable/Atom.hs src/RawFiles.hs LIB_OPTIONS=$(RTSOPTS) $(JHC_TEST) -L- -L. hunk ./Makefile.am 267 publish: docs/building.shtml docs/big-picture.pdf docs/development.shtml docs/index.shtml docs/jhc.shtml manual.html docs/manual.css cp -- $^ /home/john/public_html/computer/jhc -manual.mkd: utils/stitch.prl $(JHC_MANUAL_FILES) - perl utils/stitch.prl $(JHC_MANUAL_FILES) > $@ +manual.mkd: $(JHC_MANUAL_FILES) + perl $(srcdir)/utils/stitch.prl $^ > $@ manual: manual.mkd pandoc $< --toc -s -f markdown -t html -s -c manual.css -o $@.html hunk ./Makefile.am 273 -jhc_man.mkd: utils/stitch.prl docs/man_header.mkd $(JHC_MANUAL_FILES) - perl utils/stitch.prl -h docs/man_header.mkd -c Using,Options $(JHC_MANUAL_FILES) > jhc_man.mkd +$(firstword $(JHC_MANUAL_FILES)): utils/stitch.prl docs/man_header.mkd + touch $@ + +jhc_man.mkd: $(JHC_MANUAL_FILES) + perl $(srcdir)/utils/stitch.prl -h $(srcdir)/docs/man_header.mkd -c Using,Options $^ > $@ + man: jhc_man.mkd hunk ./Makefile.am 281 - pandoc jhc_man.mkd -s -f markdown -t man -s -o jhc.1 + pandoc $< -s -f markdown -t man -s -o jhc.1 hunk ./Makefile.am 283 -options.mkd: jhc +options.mkd: src/Options.hs | jhc echo "{-@Options 1" > $@ ./jhc --help | sed -e 's/^/ /' >> $@ hunk ./Makefile.am 288 fix-whitespace: -# #find src -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i -E 's/[[:space:]]*$$//' -# #find lib -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i -E 's/[[:space:]]*$$//' find src -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i -E 's/[ ]*$$//' find lib -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i -E 's/[ ]*$$//' hunk ./Makefile.am 303 show_elibs: lib/ext/*.cabal lib/ext/*.yaml -perl utils/build_extlibs.prl -l $^ -%: examples/%.hs jhc - ./jhc -L- -L. $(JHC_TEST) $< -o $@ 2>&1 | tee $@.log +%: examples/%.hs jhc base-1.0.hl haskell98-1.0.hl + ./jhc -L- -L$(srcdir) -L. --no-cache $(JHC_TEST) $< -o $@ # 2>&1 | tee $@.log + +TESTS=HelloWorld Primes ## autogenerated dependencies hunk ./Makefile.am 382 pretty-1.0.1.1.hl QuickCheck-1.2.0.0.hl safe-0.2.hl smallcheck-0.4.hl \ xhtml-3000.2.0.1.hl transformers-0.2.1.0.hl filepath-1.2.0.0.hl deepseq-1.1.0.2.hl -JHC_MANUAL_FILES = options.mkd docs/make.mkd docs/dependency_format.mkd docs/pragmas.mkd docs/differences.mkd \ +JHC_MANUAL_FILES = docs/make.mkd options.mkd docs/dependency_format.mkd docs/pragmas.mkd docs/differences.mkd \ docs/unboxed.mkd rts/jhc_rts2.c src/FlagOpts.mkd src/FlagDump.mkd src/E/PrimOpt.hs \ drift_processed/E/TypeCheck.hs drift_processed/Options.hs hunk ./docs/manual.css 1 +/* + * Copyright (c) 2001, 2003 The FreeBSD Documentation Project + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + * + * $FreeBSD: doc/share/misc/docbook.css,v 1.14 2008/11/21 07:28:34 keramida Exp $ + */ hunk ./docs/manual.css 29 -th { border-bottom: black 1px solid; } -img { - border: #777777 1px solid; - padding: 0.5em; - margin-left: 1em; - margin-right: 2em; - background-color: #e6e6e6; - color: black; +BODY ADDRESS { + line-height: 1.3; + margin: .6em 0; } hunk ./docs/manual.css 34 +BODY BLOCKQUOTE { + margin-top: .75em; + line-height: 1.5; + margin-bottom: .75em; +} + +HTML BODY { + margin: 1em 8% 1em 10%; + line-height: 1.2; + width: 750px; + text-align: justify; + font-size: 12px; +} + +.LEGALNOTICE { + font-size: small; + font-variant: small-caps; +} + +BODY DIV { + margin: 0; +} + +DL { + margin: .8em 0; + line-height: 1.2; +} + +BODY FORM { + margin: .6em 0; +} + +H1, H2, H4, H5, H6, +DIV.EXAMPLE P B, +.QUESTION, +DIV.TABLE P B, +DIV.PROCEDURE P B { + color: #005599; +} + +H1{ + border-bottom: 1px solid black; +} + +BODY H1, BODY H2, BODY H3, BODY H4, BODY H5, BODY H6 { + line-height: 1.3; + margin-left: 0; +} + +BODY H1, BODY H2 { + margin: .8em 0 0 -4%; +} + +BODY H3, BODY H4 { + margin: .8em 0 0 0%; + font-size: 1em; +} + +BODY H5 { + margin: .8em 0 0 -2%; +} hunk ./docs/manual.css 96 +BODY H6 { + margin: .8em 0 0 -1%; +} + +BODY HR { + margin: .6em; + border-width: 0 0 1px 0; + border-style: solid; + border-color: #cecece; +} + +BODY IMG.NAVHEADER { + margin: 0 0 0 -4%; +} + +OL { + margin: 0 0 0 5%; + line-height: 1.2; +} + +BODY PRE { + margin: .75em 0; + line-height: 1.0; + font-family: monospace; +} hunk ./docs/manual.css 122 -body { - background:#fff; - padding:2% 5%; - margin:0; +BODY TD, BODY TH { + line-height: 1.2; } hunk ./docs/manual.css 126 -a { - text-decoration:none; - font-weight:bold; - color:#c00; +UL, BODY DIR, BODY MENU { + margin: 0 0 0 5%; + line-height: 1.2; } hunk ./docs/manual.css 131 -a:visited { color:#c55; } +HTML { + margin: 0; + padding: 0; +} hunk ./docs/manual.css 136 -a:hover { - background:#000000; - color:#FFFFFF; +BODY P B.APPLICATION { + color: #000000; } hunk ./docs/manual.css 140 -div#toc { - border: #777777 1px solid; - padding: 0.5em; - margin-left: 1em; - margin-right: 2em; +.FILENAME { + color: #007a00; +} hunk ./docs/manual.css 144 +.GUIMENU, .GUIMENUITEM, .GUISUBMENU, +.GUILABEL, .INTERFACE, +.SHORTCUT, .SHORTCUT .KEYCAP { + font-weight: bold; } hunk ./docs/manual.css 150 -h1, h2, h3, h4, h1 a, h2 a, h3 a, h4 a { color:#666; } -h1, h2, h3, h4 { font-size:medium; margin:4ex 0 1ex 0; padding:0; } -h1, h2 { border-bottom: 2px solid #000; } -h3 { border-bottom: 1px dashed #000; } -h1 { font-size:large; border-bottom: 3px solid #000; margin:4ex 0 1ex 0; padding:0;} +.GUIBUTTON { + background-color: #CFCFCF; + padding: 2px; +} hunk ./docs/manual.css 155 -div.header h1 { - font-size:xx-large; margin-top:1ex; - border-bottom: 5px solid #000; +.ACCEL { + background-color: #F0F0F0; + text-decoration: underline; } hunk ./docs/manual.css 160 -hr { - border:none; - color:black; - background-color:#000; - height:2px; - margin-top:2ex; +.SCREEN { + padding: 1ex; } hunk ./docs/manual.css 164 -pre { - border: #777777 1px solid; - padding: 0.5em; - margin-left: 1em; - margin-right: 2em; - white-space: pre; - background-color: #e6e6e6; - color: black; +.PROGRAMLISTING { + padding: 1ex; + background-color: #eee; + border: 1px solid #ccc; } hunk ./docs/manual.css 170 +@media screen { /* hide from IE3 */ + a[href]:hover { background: #ffa } +} + +BLOCKQUOTE.NOTE { + color: #222; + background: #eee; + border: 1px solid #ccc; + padding: 0.4em 0.4em; + width: 85%; +} + +BLOCKQUOTE.TIP { + color: #004F00; + background: #d8ecd6; + border: 1px solid green; + padding: 0.2em 2em; + width: 85%; +} + +BLOCKQUOTE.IMPORTANT { + font-style:italic; + border: 1px solid #a00; + border-left: 12px solid #c00; + padding: 0.1em 1em; +} + +BLOCKQUOTE.WARNING { + color: #9F1313; + background: #f8e8e8; + border: 1px solid #e59595; + padding: 0.2em 2em; + width: 85%; +} + +.EXAMPLE { + background: #fefde6; + border: 1px solid #f1bb16; + margin: 1em 0; + padding: 0.2em 2em; + width: 90%; +} hunk ./utils/op_raw.prl 7 use Getopt::Std; - our $opt_c; getopts('c'); hunk ./utils/op_raw.prl 58 $nn =~ s/^.*\///; $nn =~ s/\W/_/g; - open F, "<:utf8", $fn; + open F, "<:utf8", $fn or die "$!: $fn"; $fn =~ s{/}{\\/}g; hunk ./utils/op_raw.prl 61 - print "-- | Generated from $fn on " . `date`; + print "-- | Generated from $fn\n"; header($nn); while () { line; } hunk ./utils/op_raw.prl 65 + close F or die "$!: close $fn"; + print "\"#\n\n"; } [added 0.8.0 announcment John Meacham **20120208020017 Ignore-this: 53ca4daa8631320f06e8f5b6c464bc55 ] addfile ./docs/announce/announce-0.8.0.txt hunk ./docs/announce/announce-0.8.0.txt 1 +I am happy to announce jhc 0.8.0 + +There have been A lot of major changes in jhc with this release. + + - http://repetae.net/computer/jhc + +- A brand new and sanified library description file format. Now it is a true + YAML file. The previous quasi-cabal files are supported but deprecated. + +- new standard library 'bytestring' :) + +- jhc can now embed C code and header files directly into hl libraries. The + code will automatically be unpacked and linked when needed transparently. + This allows 'bytestring' to carry around its fpsstring.c low level + implementaton for instance without having to coordinate the install of C + headers/code along with the jhc haskell library. + +- the library description files now can affect pretty much any aspect of + compilation, so it is much easier to make a self-contained build or for tools + like configure/cabal to interface to jhc. They just need to spit out an + appropriate yaml file rather than care about passing the right options to jhc + in addition to creating a description file. See the user manual for the set + of fields that can be set. + +- jhc now understands ghc-style LANGUAGE pragmas and -X options and will + translate them into the appropriate jhc extensions as needed. + +- jhc transparently handles '.hsc' files (assuming you have hsc2hs installed). + It even does the right thing when cross compiliing and will use the target + architectures types rather than the hosts. + +- the bang patterns extension has been implemented. + +- the primtive libraries have been re-done, now there is a truely absolutely + minimal jhc-prim library that is everything that must exist for jhc to work + but brinsg in no code on its own. Everything else is implemented in user + replaceable normal haskell code. + + Want to create a varient of haskell that has 16 bit Ints, ASCII 8 bit Chars + and pervasively uses null terminated C style strings? just create a base-tiny + library and link it against jhc-prim. + +- The standalone deriving extension has been partially implemented, this + greatly improves the ability to re-arrange the libraries logically. + +- Better haskell 2010 compatibility. + +- Haskell object files and the --ho-dir have been fully removed in favor of + pervasive use of the code cache. This allows jhc to cache compilation results + with finer granularity than individual files would allow. Command line + options have been renamed accordingly, we have --cache-dir, --no-cache, + --readonly-cache and --ignore-cache to modify jhcs behavior with respect to + the cache. Additionally a --purge-cache option has been added. + +- rather than trying to stuff everything in a monolithic .c file, jhc now + builds a tree containing all the source needed to compile the final + executable or shared library. This will help people porting jhc to new + architectures and allows the embedding of c code in the haskell libraries. + +- Many programs typecheked in the past that were in fact, invalid. most now + fail properly with an informative message. + +- pulled in most of the ghc typechecking regression tests. + +- internal class representation completely re-worked. + +- unboxed characters now supported, with the obvious syntax. + + + John [TAG 0.8.0 John Meacham **20120208020026 Ignore-this: 2d0d963331a43650879ae72d81ff62e8 ] < [added 0.8.0 announcment John Meacham **20120208020017 Ignore-this: 53ca4daa8631320f06e8f5b6c464bc55 ] [fixes for distribution. John Meacham **20120208015220 Ignore-this: 5844114c6728be83bd526d50333d0204 ] [clean up handling of raw files, keep source file separate when compiling. include useful header files when compiling. John Meacham **20120207115605 Ignore-this: 36df85f4ad0b25b1cafc02ecb98657cc ] [make foreign imports work with unboxed IO types, improve primitive operators. John Meacham **20120207105510 Ignore-this: b43075dce20079f7892e7f0f0c0abb66 ] [add support for 'Coerce' grin primitive, add atomic allocs in grin. John Meacham **20120207063202 Ignore-this: 64eab2e8901db764df62b6fcd471b6b7 ] [add Jhc.Prim.Rts to access properties of the RTS John Meacham **20120207015719 Ignore-this: be65a8819515ab079e2ddbd28914bed7 ] [clean up foreignptr implementation some. John Meacham **20120206181122 Ignore-this: 17b7146d0bab97deb69e907f67c61af1 ] [allow extra C code to be bundled within .hl files, include bytestring in the standard external libraries. John Meacham **20120206153022 Ignore-this: bc6f7918c92d8a0d8b62765fa7e7fa30 ] [pass -D flags to hsc2hs, add CLong and CULong instances, fill out Foreign.ForeignPtr John Meacham **20120206140318 Ignore-this: b386c32535020c2b821d481d3692987e ] [remove old references to the haskell object directory, made everything cache based. added --purge-cache John Meacham **20120206122444 Ignore-this: cf29653dddfaaf3db701cf518d7d8315 ] [update documentation, move Data.Char to base John Meacham **20120206112232 Ignore-this: 8fe0b515bdb8663d5d0f4ae199007e6b ] [remove redundant dependencies from 'base' John Meacham **20120206095209 Ignore-this: 9127c458a7453df2f5c240632b28f92e ] [include location of 'import' declaration for unknown imports, move Data.Int and Data.Word out of jhc John Meacham **20120206092730 Ignore-this: 205dad46b87c86fa1d4d99fb318fc6b8 ] [move arrays to jhc-prim, remove special IORef specific primitives in favor of length 1 arrays John Meacham **20120206081357 Ignore-this: 2f09c2c15989dcbed6cd622a0847e14 ] [remove a lot of unneeded dependencies. John Meacham **20120206065636 Ignore-this: 972533480e8d928a49abc6025a81f705 ] [create Jhc.Class.Real to hold more advance numeric classes. John Meacham **20120206061314 Ignore-this: b604268ae804a0ffc665af0115ac515 ] [add script to check for and remove unneeded imports from libraries, remove a bunch from lib/jhc/ John Meacham **20120206061304 Ignore-this: f090ccc1df9f6386009b1b59b3a8e316 ] [don't require 'error' to be in scope for where pattern desugaring, process renaming errors before kind inference John Meacham **20120206061151 Ignore-this: 9d171d1713fd41761ce5f5e33d7406d0 ] [seperate --stop parameter from compilation mode John Meacham **20120206022810 Ignore-this: c9ce415c8d84484f687ed1b465dea071 ] [use quoteName mechanism to pre-rename certain names, fix class instance namespace bug John Meacham **20120206005746 Ignore-this: 6752c4492fc492a8100cb81f25b0d50 ] [generate reverse name map during renaming John Meacham **20120205110857 Ignore-this: 7b2a4371766f7f09d1c05999e2d58349 ] [fix up library to pass the more strigent typechecking John Meacham **20120205082156 Ignore-this: 3c5499a310f582ae00991fee63b32ca6 ] [check superclass constraints on instance declarations John Meacham **20120205025815 Ignore-this: 6c5df51b853ecba4af51fba6cc4f7436 ] [properly check for duplicate instances John Meacham **20120205015651 Ignore-this: 720d6018d440148d5556cca2c42d1bb6 ] [add ghc typecheck failure tests John Meacham **20120205003034 Ignore-this: bfd5fb0ec2acfbf7f702cc7d875fabd5 ] [improve kind checking, kind check instance heads before typechecking pass, switch HsInstDecl to use the HsClassHead John Meacham **20120205000203 Ignore-this: 98d55f47020b0ef0bbbaee76296d8534 ] [switch kind inference to use the unified warnings mechanism, switch class declarations to use a HsClassHead John Meacham **20120204220732 Ignore-this: 33fc7a51ab745a8bf3ddca33fccb0a97 ] [turn WarnType into a real algebraic data type. John Meacham **20120203041757 Ignore-this: 8f057ac3d1bdeb2aa4c30277beeaff0d ] [code cleanups, used located in hstype, use packedstring for filename. John Meacham **20120201132053 Ignore-this: d679fc0c77d4750e21e37df90f397149 ] [add bange-patterns extension, add individual flags for various extensions John Meacham **20120201110217 Ignore-this: 45f6e1befab3cb368ca4e000118159f2 ] [Rework the internal class representation to separate instances from class declarations John Meacham **20120201073400 Ignore-this: b4bbb5d887a4985864ef9a27eaab606f ] [add DeNameable class to un-rename source before printing error messages. John Meacham **20120201015918 Ignore-this: 959bd035adf0dbf03cd36da091ecb519 ] [make IO a newtype of ST John Meacham **20120131214951 Ignore-this: edb87ba731c5f6146e7e349a709dd7b8 ] [speed up parsing/lexing by using Name's rather than Strings John Meacham **20120130112230 Ignore-this: cc38297046f0991709d63f4780f1665 ] [TAG mydniquipepo John Meacham **20120130095603 Ignore-this: d113eab7c2bf5df247bd49aa6ee6f823 ] > Context: [allow extra C code to be bundled within .hl files, include bytestring in the standard external libraries. John Meacham **20120206153022 Ignore-this: bc6f7918c92d8a0d8b62765fa7e7fa30 ] [pass -D flags to hsc2hs, add CLong and CULong instances, fill out Foreign.ForeignPtr John Meacham **20120206140318 Ignore-this: b386c32535020c2b821d481d3692987e ] [remove old references to the haskell object directory, made everything cache based. added --purge-cache John Meacham **20120206122444 Ignore-this: cf29653dddfaaf3db701cf518d7d8315 ] [update documentation, move Data.Char to base John Meacham **20120206112232 Ignore-this: 8fe0b515bdb8663d5d0f4ae199007e6b ] [remove redundant dependencies from 'base' John Meacham **20120206095209 Ignore-this: 9127c458a7453df2f5c240632b28f92e ] [include location of 'import' declaration for unknown imports, move Data.Int and Data.Word out of jhc John Meacham **20120206092730 Ignore-this: 205dad46b87c86fa1d4d99fb318fc6b8 ] [move arrays to jhc-prim, remove special IORef specific primitives in favor of length 1 arrays John Meacham **20120206081357 Ignore-this: 2f09c2c15989dcbed6cd622a0847e14 ] [remove a lot of unneeded dependencies. John Meacham **20120206065636 Ignore-this: 972533480e8d928a49abc6025a81f705 ] [create Jhc.Class.Real to hold more advance numeric classes. John Meacham **20120206061314 Ignore-this: b604268ae804a0ffc665af0115ac515 ] [add script to check for and remove unneeded imports from libraries, remove a bunch from lib/jhc/ John Meacham **20120206061304 Ignore-this: f090ccc1df9f6386009b1b59b3a8e316 ] [don't require 'error' to be in scope for where pattern desugaring, process renaming errors before kind inference John Meacham **20120206061151 Ignore-this: 9d171d1713fd41761ce5f5e33d7406d0 ] [seperate --stop parameter from compilation mode John Meacham **20120206022810 Ignore-this: c9ce415c8d84484f687ed1b465dea071 ] [use quoteName mechanism to pre-rename certain names, fix class instance namespace bug John Meacham **20120206005746 Ignore-this: 6752c4492fc492a8100cb81f25b0d50 ] [generate reverse name map during renaming John Meacham **20120205110857 Ignore-this: 7b2a4371766f7f09d1c05999e2d58349 ] [fix up library to pass the more strigent typechecking John Meacham **20120205082156 Ignore-this: 3c5499a310f582ae00991fee63b32ca6 ] [check superclass constraints on instance declarations John Meacham **20120205025815 Ignore-this: 6c5df51b853ecba4af51fba6cc4f7436 ] [properly check for duplicate instances John Meacham **20120205015651 Ignore-this: 720d6018d440148d5556cca2c42d1bb6 ] [add ghc typecheck failure tests John Meacham **20120205003034 Ignore-this: bfd5fb0ec2acfbf7f702cc7d875fabd5 ] [improve kind checking, kind check instance heads before typechecking pass, switch HsInstDecl to use the HsClassHead John Meacham **20120205000203 Ignore-this: 98d55f47020b0ef0bbbaee76296d8534 ] [switch kind inference to use the unified warnings mechanism, switch class declarations to use a HsClassHead John Meacham **20120204220732 Ignore-this: 33fc7a51ab745a8bf3ddca33fccb0a97 ] [turn WarnType into a real algebraic data type. John Meacham **20120203041757 Ignore-this: 8f057ac3d1bdeb2aa4c30277beeaff0d ] [code cleanups, used located in hstype, use packedstring for filename. John Meacham **20120201132053 Ignore-this: d679fc0c77d4750e21e37df90f397149 ] [add bange-patterns extension, add individual flags for various extensions John Meacham **20120201110217 Ignore-this: 45f6e1befab3cb368ca4e000118159f2 ] [Rework the internal class representation to separate instances from class declarations John Meacham **20120201073400 Ignore-this: b4bbb5d887a4985864ef9a27eaab606f ] [add DeNameable class to un-rename source before printing error messages. John Meacham **20120201015918 Ignore-this: 959bd035adf0dbf03cd36da091ecb519 ] [make IO a newtype of ST John Meacham **20120131214951 Ignore-this: edb87ba731c5f6146e7e349a709dd7b8 ] [speed up parsing/lexing by using Name's rather than Strings John Meacham **20120130112230 Ignore-this: cc38297046f0991709d63f4780f1665 ] [TAG mydniquipepo John Meacham **20120130095603 Ignore-this: d113eab7c2bf5df247bd49aa6ee6f823 ] Patch bundle hash: 080ea224e2ab2a0e05de052dc697a4255c22a065