Merge 10f4550

src/Bloc-Spec2/MemoryLogger.extension.st

@@ -2,39 +2,37 @@ Extension { #name : #MemoryLogger }
 
 { #category : #'*Bloc-Spec2' }
 MemoryLogger >> inspectorRecordingsIn: aBuilder [
-	<inspectorPresentationOrder: 0 title: 'Recordings'>
 
+	<inspectorPresentationOrder: 0 title: 'Recordings'>
 	| table refreshBlock |
 	table := aBuilder newTable.
 
 	table
 		addColumn: (SpStringTableColumn
-			title: 'Timestamp'
-			evaluated: [ :each | each timestamp asString ]);
-		addColumn: (SpStringTableColumn
-			title: 'Process'
-			evaluated: [ :each | each processId asString ]);
+				 title: 'Timestamp'
+				 evaluated: [ :each | each timestamp asString ]);
 		addColumn: (SpStringTableColumn
-			title: 'Type'
-			evaluated: [ :each | each name ]);
-		addColumn: (SpStringTableColumn
-			title: 'Contents'
-			evaluated: [ :each | String streamContents: [ :s | each printOneLineContentsOn: s ] ]).
+				 title: 'Process'
+				 evaluated: [ :each | each processId asString ]);
+		addColumn:
+			(SpStringTableColumn title: 'Type' evaluated: [ :each | each name ]);
+		addColumn:
+			(SpStringTableColumn title: 'Contents' evaluated: [ :each |
+					 String streamContents: [ :s | each printOneLineContentsOn: s ] ]).
 
-	table
-		contextMenu: (SpMenuPresenter new 
-			addItem: [ :item |
-				item
-					name: 'Remove all';
-					icon: (self iconNamed: #glamorousRemove);
-					action: [
-						self reset.
-						table refresh ] ];
-			yourself).
+	table contextMenu: (SpMenuPresenter new
+			 addItem: [ :item |
+				 item
+					 name: 'Remove all';
+					 icon: (self iconNamed: #glamorousRemove);
+					 action: [
+						 self reset.
+						 table refresh ] ];
+			 yourself).
 
 	refreshBlock := [ table items: self recordings reverse ].
 	refreshBlock value.
-	self announcer weak when: Announcement do: refreshBlock.
+	self announcer weak when: Announcement do: refreshBlock for: self.
 
 	^ table
 ]

src/Bloc-Tests/BlHostPulseLoopTest.class.st

@@ -0,0 +1,48 @@
+Class {
+	#name : #BlHostPulseLoopTest,
+	#superclass : #BlParameterizedHostTest,
+	#category : #'Bloc-Tests-Space'
+}
+
+{ #category : #running }
+BlHostPulseLoopTest >> runCaseManaged [ 
+
+	^ self runCase
+]
+
+{ #category : #tests }
+BlHostPulseLoopTest >> testOpeningAnSpaceDeferingAnErrorKeepsLoopRunning [
+
+	| aSpace logger |
+
+	UIManager default class = MorphicUIManager 
+		ifFalse: [ ^ self skip ].
+
+	hostClass = BlOSWindowSDL2Host 
+		ifFalse: [ ^ self skip ].
+
+	aSpace := self newTestingSpace.
+	aSpace root addChild: (BlElement new background: Color blue; yourself).
+
+	aSpace show.
+
+	logger := MemoryLogger new.
+	logger runFor: BlParallelUniverseErrorDuringPulse during: [	
+			aSpace universe defer: [ 1 error: 'I am the debugger to kill' ].	
+			[aSpace universe hasDeferredActions] whileTrue: [ 
+				100 milliSeconds wait
+			 ]].
+
+	self assert: logger recordings size equals: 2.
+	self assert: logger recordings first signaledError class equals: Error.
+	self assert: logger recordings second signaledError class equals: UnhandledError.
+
+	MorphicRenderLoop new doOneCycle.
+
+	"This is horrible, I will fix Pharo to have a list of open debuggers"
+	StDebugger allInstances 
+		detect: [ :e | e window title = 'Error: I am the debugger to kill' ]
+		ifFound: [ :x | x window close ]
+		ifNone: [ self fail ].
+
+]

src/Bloc/BlHostPulseLoop.class.st

@@ -103,31 +103,42 @@ BlHostPulseLoop >> isRunningInTheSameProcess [
 	^ Processor activeProcess effectiveProcess == loopProcess
 ]
 
-{ #category : #accessing }
-BlHostPulseLoop >> loopProcess [
+{ #category : #'loop process' }
+BlHostPulseLoop >> loop [
 
-	^ loopProcess
+	[ self loopIteration ] whileTrue
 ]
 
 { #category : #'loop process' }
-BlHostPulseLoop >> newLoopBlock [
+BlHostPulseLoop >> loopIteration [
 
-	^ [ [
-			pulseStartMS := Time millisecondClockValue.
+	| universe |
 
-			(BlParallelUniverse forHost: hostClass) pulse.
+	[
+		pulseStartMS := Time millisecondClockValue.
+		universe := BlParallelUniverse forHost: hostClass.
+		universe pulse.
+		pulseDurationMS := Time millisecondClockValue - pulseStartMS.
+		self waitUntilNextPulse. ]
+	on: Exception
+	do: [ :e |
+			self forceStartNewUIProcess.
+		e pass ].
 
-			pulseDurationMS := Time millisecondClockValue - pulseStartMS.
+	"Returns true to continue looping"
+	^ self isRunningInTheSameProcess 
+]
 
-			self waitUntilNextPulse 
-
-		] doWhileTrue: [ loopProcess == Processor activeProcess ] ]
+{ #category : #accessing }
+BlHostPulseLoop >> loopProcess [
+
+	^ loopProcess
 ]
 
 { #category : #'loop process' }
 BlHostPulseLoop >> newLoopProcess [
 
-	^ self newLoopBlock newProcess
+	^ [ self loop ] newProcess
 		  priority: self processPriority;
 		  name: self processId;
 		  yourself

src/Bloc/BlParallelUniverse.class.st

@@ -13,8 +13,7 @@ Class {
 		'postponedActions',
 		'eventDispatcher',
 		'hostClass',
-		'spaceManager',
-		'isPulsing'
+		'spaceManager'
 	],
 	#classVars : [
 		'UniqueIdGenerator',
@@ -288,6 +287,12 @@ BlParallelUniverse >> eventDispatcher [
 	^ eventDispatcher
 ]
 
+{ #category : #testing }
+BlParallelUniverse >> hasDeferredActions [
+
+	^ deferredActions isEmpty not
+]
+
 { #category : #'api - spaces' }
 BlParallelUniverse >> hasSpace: aSpace [
 	"Return true if a given space is registered, false otherwise"
@@ -337,23 +342,11 @@ BlParallelUniverse >> initialize [
 	hostClass := BlHeadlessHost.
 	deferredActions := WaitfreeQueue new.
 	postponedActions := WaitfreeQueue new.
-	isPulsing := false.
 
 	eventDispatcher := self defaultEventDispatcher.
 	self addEventHandler: self defaultEventListener
 ]
 
-{ #category : #accessing }
-BlParallelUniverse >> isPulsing [
-
-	^ isPulsing
-]
-
-{ #category : #'private - spaces' }
-BlParallelUniverse >> markAsNotPulsing [
-	isPulsing := false
-]
-
 { #category : #'api - spaces' }
 BlParallelUniverse >> openSpace: aSpace [
 	"It should be possible to add a space from the other thread"
@@ -441,32 +434,24 @@ BlParallelUniverse >> postpone: aValuable [
 { #category : #pulse }
 BlParallelUniverse >> pulse [
 
-	isPulsing ifTrue: [ ^ self ].
-
-	isPulsing := true.
-
-	[ self pulseSynchronously ] ensure: [ self requestStopPulsation ]
+	self pulseSynchronously
 ]
 
 { #category : #'private - spaces' }
 BlParallelUniverse >> pulseSynchronously [
 	"deferred actions must be run before spaces"
+
 	[
 		self tryToRunDeferredActions.
-		spaceManager do: [ :eachSpace | eachSpace pulse ]
-	] ensure: [ self tryToRunPostponedActions ]
-]
-
-{ #category : #'private - spaces' }
-BlParallelUniverse >> requestStopPulsation [
-
-		self uiProcessDo: [ :currentUIProcess | 
-			"Only mark the universe as not pulsing in case the request comes from the current
-			UI process or from a process that was not the Bloc UI process previously. This avoids 
-			reseting the pulsing status when the debugger terminates a previously suspended UI process."
-			(Processor activeProcess == currentUIProcess or: [
-			Processor activeProcess name ~= BlHostPulseLoop processId ])
-				ifTrue: [ self markAsNotPulsing ] ]
+		spaceManager do: [ :eachSpace | eachSpace pulse ].
+		self tryToRunPostponedActions
+	] 
+		on: Exception 
+		do: [ :e | 
+				(BlParallelUniverseErrorDuringPulse new
+					signaledError: e;
+					yourself) emit.
+				e pass ]
 ]
 
 { #category : #'api - lifecycle' }
@@ -486,7 +471,6 @@ BlParallelUniverse >> startUniverse [
 	"A universe must not be running here.
 	I am called outside of the UI loop (there is no UI loop yet)"
 
-	self markAsNotPulsing.
 	self hostClass start
 ]
 
@@ -495,9 +479,7 @@ BlParallelUniverse >> stopUniverse [
 	"A universe must be running here.
 	I am called from the UI loop"
 
-	"to make sure that isPulsing is set back to false even if this Process is terminated"
-	[ self hostClass stop ]
-		ensure: [ self markAsNotPulsing ]
+	self hostClass stop
 ]
 
 { #category : #'deferred message' }
@@ -514,15 +496,15 @@ BlParallelUniverse >> tryToRunDeferredActions [
 			universeId: self id;
 			yourself) emit.
 
-		[ nextInQueue value ] on: UnhandledError fork: [ :ex | ex pass ] ]
+		nextInQueue value ]
 ]
 
 { #category : #'deferred message' }
 BlParallelUniverse >> tryToRunPostponedActions [
 
 	| nextInQueue |
 	[ (nextInQueue := postponedActions nextOrNil) isNotNil ] whileTrue: [ 
-		[ nextInQueue value ] on: UnhandledError fork: [ :ex | ex pass ] ]
+		nextInQueue value ]
 ]
 
 { #category : #'api - ui process' }

src/Bloc/BlParallelUniverseErrorDuringPulse.class.st

@@ -0,0 +1,24 @@
+"
+I am a signal that is raised when there is an error in the pulse.
+I include in myself the signaledError.
+"
+Class {
+	#name : #BlParallelUniverseErrorDuringPulse,
+	#superclass : #BlParallelUniverseSignal,
+	#instVars : [
+		'signaledError'
+	],
+	#category : #'Bloc-Universe - Parallel'
+}
+
+{ #category : #accessing }
+BlParallelUniverseErrorDuringPulse >> signaledError [
+
+	^ signaledError
+]
+
+{ #category : #accessing }
+BlParallelUniverseErrorDuringPulse >> signaledError: anObject [
+
+	signaledError := anObject
+]

src/BlocHost-Morphic/BlBlocUIManager.class.st

@@ -514,7 +514,6 @@ BlBlocUIManager >> resumeUIProcess: aProcess [
 
 { #category : #debug }
 BlBlocUIManager >> spawnNewBlocProcess: aUniverse [
-	aUniverse requestStopPulsation.
 	aUniverse hostClass forceStartNewUIProcess
 ]
 

src/BlocHost-Morphic/BlMorphicSteppingHost.class.st

@@ -35,7 +35,8 @@ BlMorphicSteppingHost class >> start [
 
 { #category : #'private - stepping' }
 BlMorphicSteppingHost class >> step [
-	(BlParallelUniverse forHost: self) pulse
+	[(BlParallelUniverse forHost: self) pulse] 
+		on: Exception do: [ :e | self start. e pass ]
 ]
 
 { #category : #'api - lifecycle' }